feat: add builtin simproc support

src/Lean/Elab/Tactic/Simproc.lean

@@ -13,13 +13,17 @@ namespace Lean.Elab
 
 open Lean Meta Simp
 
-def elabPattern (stx : Syntax) : MetaM Expr := do
+def elabSimprocPattern (stx : Syntax) : MetaM Expr := do
   let go : TermElabM Expr := do
     let pattern ← Term.elabTerm stx none
     Term.synthesizeSyntheticMVars
     return pattern
   go.run'
 
+def elabSimprocKeys (stx : Syntax) : MetaM (Array Meta.SimpTheoremKey) := do
+  let pattern ← elabSimprocPattern stx
+  DiscrTree.mkPath pattern simpDtConfig
+
 def checkSimprocType (declName : Name) : CoreM Unit := do
   let decl ← getConstInfo declName
   match decl.type with
@@ -30,13 +34,23 @@ namespace Command
 
 @[builtin_command_elab Lean.Parser.simprocPattern] def elabSimprocPattern : CommandElab := fun stx => do
   let `(simproc_pattern% $pattern => $declName) := stx | throwUnsupportedSyntax
-  let declName := declName.getId
+  let declName ← resolveGlobalConstNoOverload declName
   liftTermElabM do
     checkSimprocType declName
-    let pattern ← elabPattern pattern
-    let keys ← DiscrTree.mkPath pattern simpDtConfig
+    let keys ← elabSimprocKeys pattern
     registerSimproc declName keys
 
+@[builtin_command_elab Lean.Parser.simprocPatternBuiltin] def elabSimprocPatternBuiltin : CommandElab := fun stx => do
+  let `(builtin_simproc_pattern% $pattern => $declName) := stx | throwUnsupportedSyntax
+  let declName ← resolveGlobalConstNoOverload declName
+  liftTermElabM do
+    checkSimprocType declName
+    let keys ← elabSimprocKeys pattern
+    registerSimproc declName keys
+    let val := mkAppN (mkConst ``registerBuiltinSimproc) #[toExpr declName, toExpr keys]
+    let initDeclName ← mkFreshUserName (declName ++ `declare)
+    declareBuiltin initDeclName val
+
 end Command
 
 builtin_initialize
@@ -53,4 +67,20 @@ builtin_initialize
     applicationTime := AttributeApplicationTime.afterCompilation
   }
 
+builtin_initialize
+  registerBuiltinAttribute {
+    ref             := by exact decl_name%
+    name            := `simprocBuiltinAttr
+    descr           := "Builtin simplification procedure"
+    erase           := eraseSimprocAttr
+    add             := fun declName stx _ => do
+      let go : MetaM Unit := do
+        let post := if stx[1].isNone then true else stx[1][0].getKind == ``Lean.Parser.Tactic.simpPost
+        let val := mkAppN (mkConst ``addSimprocBuiltinAttr) #[toExpr declName, toExpr post, mkConst declName]
+        let initDeclName ← mkFreshUserName (declName ++ `declare)
+        declareBuiltin initDeclName val
+      go.run' {}
+    applicationTime := AttributeApplicationTime.afterCompilation
+  }
+
 end Lean.Elab

src/Lean/Meta/DiscrTreeTypes.lean

@@ -4,6 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Leonardo de Moura
 -/
 import Lean.Expr
+import Lean.ToExpr
 
 namespace Lean.Meta
 
@@ -34,6 +35,17 @@ protected def Key.hash : Key → UInt64
 
 instance : Hashable Key := ⟨Key.hash⟩
 
+instance : ToExpr Key where
+  toTypeExpr := mkConst ``Key
+  toExpr k   := match k with
+   | .const n a => mkApp2 (mkConst ``Key.const) (toExpr n) (toExpr a)
+   | .fvar id a => mkApp2 (mkConst ``Key.fvar) (toExpr id) (toExpr a)
+   | .lit l => mkApp (mkConst ``Key.lit) (toExpr l)
+   | .star => mkConst ``Key.star
+   | .other => mkConst ``Key.other
+   | .arrow => mkConst ``Key.arrow
+   | .proj n i a => mkApp3 (mkConst ``Key.proj) (toExpr n) (toExpr i) (toExpr a)
+
 /--
 Discrimination tree trie. See `DiscrTree`.
 -/

src/Lean/Meta/Tactic/Simp/Simproc.lean

@@ -124,6 +124,14 @@ def Simprocs.add (s : Simprocs) (declName : Name) (post : Bool) : CoreM Simprocs
   else
     return { s with pre := s.pre.insertCore keys { declName, keys, post, proc } }
 
+def addSimprocBuiltinAttr (declName : Name) (post : Bool) (proc : Simproc) : IO Unit := do
+  let some keys := (← builtinSimprocDeclsRef.get).find? declName |
+    throw (IO.userError "invalid [builtin_simproc] attribute, '{declName}' is not a builtin simproc")
+  if post then
+    builtinSimprocsRef.modify fun s => { s with post := s.post.insertCore keys { declName, keys, post, proc } }
+  else
+    builtinSimprocsRef.modify fun s => { s with pre := s.pre.insertCore keys { declName, keys, post, proc } }
+
 def getSimprocs : CoreM Simprocs :=
   return simprocExtension.getState (← getEnv)
 

src/Lean/ToExpr.lean

@@ -100,6 +100,16 @@ instance [ToExpr α] [ToExpr β] : ToExpr (α × β) :=
   { toExpr     := fun ⟨a, b⟩ => mkApp4 (mkConst ``Prod.mk [levelZero, levelZero]) αType βType (toExpr a) (toExpr b),
     toTypeExpr := mkApp2 (mkConst ``Prod [levelZero, levelZero]) αType βType }
 
+instance : ToExpr Literal where
+  toTypeExpr := mkConst ``Literal
+  toExpr l   := match l with
+   | .natVal _ => mkApp (mkConst ``Literal.natVal) (.lit l)
+   | .strVal _ => mkApp (mkConst ``Literal.strVal) (.lit l)
+
+instance : ToExpr FVarId where
+  toTypeExpr    := mkConst ``FVarId
+  toExpr fvarId := mkApp (mkConst ``FVarId.mk) (toExpr fvarId.name)
+
 def Expr.toCtorIfLit : Expr → Expr
   | .lit (.natVal v) =>
     if v == 0 then mkConst ``Nat.zero