diff --git a/src/Lean/Meta/Tactic/NormCast.lean b/src/Lean/Meta/Tactic/NormCast.lean index c0cc81cf2256..d727d309c841 100644 --- a/src/Lean/Meta/Tactic/NormCast.lean +++ b/src/Lean/Meta/Tactic/NormCast.lean @@ -5,7 +5,7 @@ Authors: Paul-Nicolas Madelaine, Robert Y. Lewis, Mario Carneiro, Gabriel Ebner -/ prelude import Lean.Meta.CongrTheorems -import Lean.Meta.Tactic.Simp.SimpTheorems +import Lean.Meta.Tactic.Simp.Attr import Lean.Meta.CoeAttr namespace Lean.Meta.NormCast diff --git a/src/Lean/Meta/Tactic/Simp.lean b/src/Lean/Meta/Tactic/Simp.lean index 3afb43498f00..6987220330c7 100644 --- a/src/Lean/Meta/Tactic/Simp.lean +++ b/src/Lean/Meta/Tactic/Simp.lean @@ -13,6 +13,7 @@ import Lean.Meta.Tactic.Simp.SimpAll import Lean.Meta.Tactic.Simp.Simproc import Lean.Meta.Tactic.Simp.BuiltinSimprocs import Lean.Meta.Tactic.Simp.RegisterCommand +import Lean.Meta.Tactic.Simp.Attr namespace Lean diff --git a/src/Lean/Meta/Tactic/Simp/Attr.lean b/src/Lean/Meta/Tactic/Simp/Attr.lean new file mode 100644 index 000000000000..bf5755534407 --- /dev/null +++ b/src/Lean/Meta/Tactic/Simp/Attr.lean @@ -0,0 +1,64 @@ +/- +Copyright (c) 2024 Amazon.com, Inc. or its affiliates. All Rights Reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Lean.Meta.Tactic.Simp.SimpTheorems +import Lean.Meta.Tactic.Simp.Types + +namespace Lean.Meta + +def mkSimpAttr (attrName : Name) (attrDescr : String) (ext : SimpExtension) + (ref : Name := by exact decl_name%) : IO Unit := + registerBuiltinAttribute { + ref := ref + name := attrName + descr := attrDescr + applicationTime := AttributeApplicationTime.afterCompilation + add := fun declName stx attrKind => + let go : MetaM Unit := do + let info ← getConstInfo declName + let post := if stx[1].isNone then true else stx[1][0].getKind == ``Lean.Parser.Tactic.simpPost + let prio ← getAttrParamOptPrio stx[2] + if (← isProp info.type) then + addSimpTheorem ext declName post (inv := false) attrKind prio + else if info.hasValue then + if let some eqns ← getEqnsFor? declName then + for eqn in eqns do + addSimpTheorem ext eqn post (inv := false) attrKind prio + ext.add (SimpEntry.toUnfoldThms declName eqns) attrKind + if hasSmartUnfoldingDecl (← getEnv) declName then + ext.add (SimpEntry.toUnfold declName) attrKind + else + ext.add (SimpEntry.toUnfold declName) attrKind + else + throwError "invalid 'simp', it is not a proposition nor a definition (to unfold)" + discard <| go.run {} {} + erase := fun declName => do + let s := ext.getState (← getEnv) + let s ← s.erase (.decl declName) + modifyEnv fun env => ext.modifyState env fun _ => s + } + +def registerSimpAttr (attrName : Name) (attrDescr : String) + (ref : Name := by exact decl_name%) : IO SimpExtension := do + let ext ← mkSimpExt ref + mkSimpAttr attrName attrDescr ext ref -- Remark: it will fail if it is not performed during initialization + simpExtensionMapRef.modify fun map => map.insert attrName ext + return ext + +builtin_initialize simpExtension : SimpExtension ← registerSimpAttr `simp "simplification theorem" + +builtin_initialize sevalSimpExtension : SimpExtension ← registerSimpAttr `seval "symbolic evaluator theorem" + +def getSimpTheorems : CoreM SimpTheorems := + simpExtension.getTheorems + +def getSEvalTheorems : CoreM SimpTheorems := + sevalSimpExtension.getTheorems + +def Simp.Context.mkDefault : MetaM Context := + return { config := {}, simpTheorems := #[(← Meta.getSimpTheorems)], congrTheorems := (← Meta.getSimpCongrTheorems) } + +end Lean.Meta diff --git a/src/Lean/Meta/Tactic/Simp/Rewrite.lean b/src/Lean/Meta/Tactic/Simp/Rewrite.lean index 39197f24fcd4..90e83f5235df 100644 --- a/src/Lean/Meta/Tactic/Simp/Rewrite.lean +++ b/src/Lean/Meta/Tactic/Simp/Rewrite.lean @@ -12,6 +12,7 @@ import Lean.Meta.Tactic.UnifyEq import Lean.Meta.Tactic.Simp.Types import Lean.Meta.Tactic.LinearArith.Simp import Lean.Meta.Tactic.Simp.Simproc +import Lean.Meta.Tactic.Simp.Attr namespace Lean.Meta.Simp diff --git a/src/Lean/Meta/Tactic/Simp/SimpTheorems.lean b/src/Lean/Meta/Tactic/Simp/SimpTheorems.lean index 44816e98a6e1..143f226246e3 100644 --- a/src/Lean/Meta/Tactic/Simp/SimpTheorems.lean +++ b/src/Lean/Meta/Tactic/Simp/SimpTheorems.lean @@ -362,37 +362,6 @@ def addSimpTheorem (ext : SimpExtension) (declName : Name) (post : Bool) (inv : for simpThm in simpThms do ext.add (SimpEntry.thm simpThm) attrKind -def mkSimpAttr (attrName : Name) (attrDescr : String) (ext : SimpExtension) - (ref : Name := by exact decl_name%) : IO Unit := - registerBuiltinAttribute { - ref := ref - name := attrName - descr := attrDescr - applicationTime := AttributeApplicationTime.afterCompilation - add := fun declName stx attrKind => - let go : MetaM Unit := do - let info ← getConstInfo declName - let post := if stx[1].isNone then true else stx[1][0].getKind == ``Lean.Parser.Tactic.simpPost - let prio ← getAttrParamOptPrio stx[2] - if (← isProp info.type) then - addSimpTheorem ext declName post (inv := false) attrKind prio - else if info.hasValue then - if let some eqns ← getEqnsFor? declName then - for eqn in eqns do - addSimpTheorem ext eqn post (inv := false) attrKind prio - ext.add (SimpEntry.toUnfoldThms declName eqns) attrKind - if hasSmartUnfoldingDecl (← getEnv) declName then - ext.add (SimpEntry.toUnfold declName) attrKind - else - ext.add (SimpEntry.toUnfold declName) attrKind - else - throwError "invalid 'simp', it is not a proposition nor a definition (to unfold)" - discard <| go.run {} {} - erase := fun declName => do - let s := ext.getState (← getEnv) - let s ← s.erase (.decl declName) - modifyEnv fun env => ext.modifyState env fun _ => s - } def mkSimpExt (name : Name := by exact decl_name%) : IO SimpExtension := registerSimpleScopedEnvExtension { @@ -409,26 +378,9 @@ abbrev SimpExtensionMap := HashMap Name SimpExtension builtin_initialize simpExtensionMapRef : IO.Ref SimpExtensionMap ← IO.mkRef {} -def registerSimpAttr (attrName : Name) (attrDescr : String) - (ref : Name := by exact decl_name%) : IO SimpExtension := do - let ext ← mkSimpExt ref - mkSimpAttr attrName attrDescr ext ref -- Remark: it will fail if it is not performed during initialization - simpExtensionMapRef.modify fun map => map.insert attrName ext - return ext - -builtin_initialize simpExtension : SimpExtension ← registerSimpAttr `simp "simplification theorem" - -builtin_initialize sevalSimpExtension : SimpExtension ← registerSimpAttr `seval "symbolic evaluator theorem" - def getSimpExtension? (attrName : Name) : IO (Option SimpExtension) := return (← simpExtensionMapRef.get).find? attrName -def getSimpTheorems : CoreM SimpTheorems := - simpExtension.getTheorems - -def getSEvalTheorems : CoreM SimpTheorems := - sevalSimpExtension.getTheorems - /-- Auxiliary method for adding a global declaration to a `SimpTheorems` datastructure. -/ def SimpTheorems.addConst (s : SimpTheorems) (declName : Name) (post := true) (inv := false) (prio : Nat := eval_prio default) : MetaM SimpTheorems := do let s := { s with erased := s.erased.erase (.decl declName post inv) } diff --git a/src/Lean/Meta/Tactic/Simp/Types.lean b/src/Lean/Meta/Tactic/Simp/Types.lean index b778788bbb70..bc722b8870e5 100644 --- a/src/Lean/Meta/Tactic/Simp/Types.lean +++ b/src/Lean/Meta/Tactic/Simp/Types.lean @@ -92,9 +92,6 @@ structure Context where def Context.isDeclToUnfold (ctx : Context) (declName : Name) : Bool := ctx.simpTheorems.isDeclToUnfold declName -def Context.mkDefault : MetaM Context := - return { config := {}, simpTheorems := #[(← getSimpTheorems)], congrTheorems := (← getSimpCongrTheorems) } - abbrev UsedSimps := HashMap Origin Nat structure State where