feat: Prograde tactics #83

Merged
aniva merged 24 commits from tactic/eval into dev 2024-08-31 20:04:39 -07:00
8 changed files with 141 additions and 130 deletions
Showing only changes of commit 5b4f8a37eb - Show all commits

View File

@ -383,13 +383,13 @@ protected def GoalState.tryMotivatedApply (state: GoalState) (goalId: Nat) (recu
let recursor ← match (← Compile.parseTermM recursor) with let recursor ← match (← Compile.parseTermM recursor) with
| .ok syn => pure syn | .ok syn => pure syn
| .error error => return .parseError error | .error error => return .parseError error
state.tryTacticM goalId (tacticM := Tactic.motivatedApply recursor) state.tryTacticM goalId (tacticM := Tactic.evalMotivatedApply recursor)
protected def GoalState.tryNoConfuse (state: GoalState) (goalId: Nat) (eq: String): protected def GoalState.tryNoConfuse (state: GoalState) (goalId: Nat) (eq: String):
Elab.TermElabM TacticResult := do Elab.TermElabM TacticResult := do
state.restoreElabM state.restoreElabM
let eq ← match (← Compile.parseTermM eq) with let eq ← match (← Compile.parseTermM eq) with
| .ok syn => pure syn | .ok syn => pure syn
| .error error => return .parseError error | .error error => return .parseError error
state.tryTacticM goalId (tacticM := Tactic.noConfuse eq) state.tryTacticM goalId (tacticM := Tactic.evalNoConfuse eq)
end Pantograph end Pantograph

View File

@ -192,11 +192,5 @@ def goalCalc (state: GoalState) (goalId: Nat) (pred: String): CoreM TacticResult
@[export pantograph_goal_focus] @[export pantograph_goal_focus]
def goalFocus (state: GoalState) (goalId: Nat): Option GoalState := def goalFocus (state: GoalState) (goalId: Nat): Option GoalState :=
state.focus goalId state.focus goalId
@[export pantograph_goal_motivated_apply_m]
def goalMotivatedApply (state: GoalState) (goalId: Nat) (recursor: String): CoreM TacticResult :=
runTermElabM <| state.tryMotivatedApply goalId recursor
@[export pantograph_goal_no_confuse_m]
def goalNoConfuse (state: GoalState) (goalId: Nat) (eq: String): CoreM TacticResult :=
runTermElabM <| state.tryNoConfuse goalId eq
end Pantograph end Pantograph

View File

@ -4,12 +4,12 @@ open Lean
namespace Pantograph.Tactic namespace Pantograph.Tactic
def congruenceArg: Elab.Tactic.TacticM Unit := do def congruenceArg (mvarId: MVarId): MetaM (List MVarId) := mvarId.withContext do
let goal ← Elab.Tactic.getMainGoal mvarId.checkNotAssigned `Pantograph.Tactic.congruenceArg
let .some (β, _, _) := (← goal.getType).eq? | throwError "Goal is not an Eq" let target ← mvarId.getType
let userName := (← goal.getDecl).userName let .some (β, _, _) := target.eq? | throwError "Goal is not an Eq"
let userName := (← mvarId.getDecl).userName
let nextGoals ← goal.withContext do
let u ← Meta.mkFreshLevelMVar let u ← Meta.mkFreshLevelMVar
let α ← Meta.mkFreshExprMVar (.some $ mkSort u) let α ← Meta.mkFreshExprMVar (.some $ mkSort u)
.natural (userName := userName ++ `α) .natural (userName := userName ++ `α)
@ -21,19 +21,23 @@ def congruenceArg: Elab.Tactic.TacticM Unit := do
.synthetic (userName := userName ++ `a₂) .synthetic (userName := userName ++ `a₂)
let h ← Meta.mkFreshExprMVar (.some $ ← Meta.mkEq a₁ a₂) let h ← Meta.mkFreshExprMVar (.some $ ← Meta.mkEq a₁ a₂)
.synthetic (userName := userName ++ `h) .synthetic (userName := userName ++ `h)
let conduitType ← Meta.mkEq (← Meta.mkEq (.app f a₁) (.app f a₂)) (← goal.getType) let conduitType ← Meta.mkEq (← Meta.mkEq (.app f a₁) (.app f a₂)) target
let conduit ← Meta.mkFreshExprMVar conduitType let conduit ← Meta.mkFreshExprMVar conduitType
.synthetic (userName := userName ++ `conduit) .synthetic (userName := userName ++ `conduit)
goal.assign $ ← Meta.mkEqMP conduit (← Meta.mkCongrArg f h) mvarId.assign $ ← Meta.mkEqMP conduit (← Meta.mkCongrArg f h)
return [α, a₁, a₂, f, h, conduit] let result := [α, a₁, a₂, f, h, conduit]
Elab.Tactic.setGoals <| nextGoals.map (·.mvarId!) return result.map (·.mvarId!)
def congruenceFun: Elab.Tactic.TacticM Unit := do def evalCongruenceArg: Elab.Tactic.TacticM Unit := do
let goal ← Elab.Tactic.getMainGoal let goal ← Elab.Tactic.getMainGoal
let .some (β, _, _) := (← goal.getType).eq? | throwError "Goal is not an Eq" let nextGoals ← congruenceArg goal
let userName := (← goal.getDecl).userName Elab.Tactic.setGoals nextGoals
let nextGoals ← goal.withContext do def congruenceFun (mvarId: MVarId): MetaM (List MVarId) := mvarId.withContext do
mvarId.checkNotAssigned `Pantograph.Tactic.congruenceFun
let target ← mvarId.getType
let .some (β, _, _) := target.eq? | throwError "Goal is not an Eq"
let userName := (← mvarId.getDecl).userName
let u ← Meta.mkFreshLevelMVar let u ← Meta.mkFreshLevelMVar
let α ← Meta.mkFreshExprMVar (.some $ mkSort u) let α ← Meta.mkFreshExprMVar (.some $ mkSort u)
.natural (userName := userName ++ `α) .natural (userName := userName ++ `α)
@ -46,19 +50,23 @@ def congruenceFun: Elab.Tactic.TacticM Unit := do
.synthetic (userName := userName ++ `a) .synthetic (userName := userName ++ `a)
let h ← Meta.mkFreshExprMVar (.some $ ← Meta.mkEq f₁ f₂) let h ← Meta.mkFreshExprMVar (.some $ ← Meta.mkEq f₁ f₂)
.synthetic (userName := userName ++ `h) .synthetic (userName := userName ++ `h)
let conduitType ← Meta.mkEq (← Meta.mkEq (.app f₁ a) (.app f₂ a)) (← goal.getType) let conduitType ← Meta.mkEq (← Meta.mkEq (.app f₁ a) (.app f₂ a)) target
let conduit ← Meta.mkFreshExprMVar conduitType let conduit ← Meta.mkFreshExprMVar conduitType
.synthetic (userName := userName ++ `conduit) .synthetic (userName := userName ++ `conduit)
goal.assign $ ← Meta.mkEqMP conduit (← Meta.mkCongrFun h a) mvarId.assign $ ← Meta.mkEqMP conduit (← Meta.mkCongrFun h a)
return [α, f₁, f₂, h, a, conduit] let result := [α, f₁, f₂, h, a, conduit]
Elab.Tactic.setGoals <| nextGoals.map (·.mvarId!) return result.map (·.mvarId!)
def congruence: Elab.Tactic.TacticM Unit := do def evalCongruenceFun: Elab.Tactic.TacticM Unit := do
let goal ← Elab.Tactic.getMainGoal let goal ← Elab.Tactic.getMainGoal
let .some (β, _, _) := (← goal.getType).eq? | throwError "Goal is not an Eq" let nextGoals ← congruenceFun goal
let userName := (← goal.getDecl).userName Elab.Tactic.setGoals nextGoals
let nextGoals ← goal.withContext do def congruence (mvarId: MVarId): MetaM (List MVarId) := mvarId.withContext do
mvarId.checkNotAssigned `Pantograph.Tactic.congruence
let target ← mvarId.getType
let .some (β, _, _) := target.eq? | throwError "Goal is not an Eq"
let userName := (← mvarId.getDecl).userName
let u ← Meta.mkFreshLevelMVar let u ← Meta.mkFreshLevelMVar
let α ← Meta.mkFreshExprMVar (.some $ mkSort u) let α ← Meta.mkFreshExprMVar (.some $ mkSort u)
.natural (userName := userName ++ `α) .natural (userName := userName ++ `α)
@ -75,11 +83,16 @@ def congruence: Elab.Tactic.TacticM Unit := do
.synthetic (userName := userName ++ `h₁) .synthetic (userName := userName ++ `h₁)
let h₂ ← Meta.mkFreshExprMVar (.some $ ← Meta.mkEq a₁ a₂) let h₂ ← Meta.mkFreshExprMVar (.some $ ← Meta.mkEq a₁ a₂)
.synthetic (userName := userName ++ `h₂) .synthetic (userName := userName ++ `h₂)
let conduitType ← Meta.mkEq (← Meta.mkEq (.app f₁ a₁) (.app f₂ a₂)) (← goal.getType) let conduitType ← Meta.mkEq (← Meta.mkEq (.app f₁ a₁) (.app f₂ a₂)) target
let conduit ← Meta.mkFreshExprMVar conduitType let conduit ← Meta.mkFreshExprMVar conduitType
.synthetic (userName := userName ++ `conduit) .synthetic (userName := userName ++ `conduit)
goal.assign $ ← Meta.mkEqMP conduit (← Meta.mkCongr h₁ h₂) mvarId.assign $ ← Meta.mkEqMP conduit (← Meta.mkCongr h₁ h₂)
return [α, f₁, f₂, a₁, a₂, h₁, h₂, conduit] let result := [α, f₁, f₂, a₁, a₂, h₁, h₂, conduit]
Elab.Tactic.setGoals <| nextGoals.map (·.mvarId!) return result.map (·.mvarId!)
def evalCongruence: Elab.Tactic.TacticM Unit := do
let goal ← Elab.Tactic.getMainGoal
let nextGoals ← congruence goal
Elab.Tactic.setGoals nextGoals
end Pantograph.Tactic end Pantograph.Tactic

View File

@ -62,13 +62,10 @@ def collectMotiveArguments (forallBody: Expr): SSet Nat :=
| _ => SSet.empty | _ => SSet.empty
/-- Applies a symbol of the type `∀ (motive: α → Sort u) (a: α)..., (motive α)` -/ /-- Applies a symbol of the type `∀ (motive: α → Sort u) (a: α)..., (motive α)` -/
def motivatedApply: Elab.Tactic.Tactic := λ stx => do def motivatedApply (mvarId: MVarId) (recursor: Expr) : MetaM (List Meta.InductionSubgoal) := mvarId.withContext do
let goal ← Elab.Tactic.getMainGoal mvarId.checkNotAssigned `Pantograph.Tactic.motivatedApply
let nextGoals: List MVarId ← goal.withContext do
let recursor ← Elab.Term.elabTerm (stx := stx) .none
let recursorType ← Meta.inferType recursor let recursorType ← Meta.inferType recursor
let resultant ← mvarId.getType
let resultant ← goal.getType
let info ← match getRecursorInformation recursorType with let info ← match getRecursorInformation recursorType with
| .some info => pure info | .some info => pure info
@ -95,11 +92,14 @@ def motivatedApply: Elab.Tactic.Tactic := λ stx => do
-- Create the conduit type which proves the result of the motive is equal to the goal -- Create the conduit type which proves the result of the motive is equal to the goal
let conduitType ← info.conduitType newMVars resultant let conduitType ← info.conduitType newMVars resultant
let goalConduit ← Meta.mkFreshExprMVar conduitType .natural (userName := `conduit) let goalConduit ← Meta.mkFreshExprMVar conduitType .natural (userName := `conduit)
goal.assign $ ← Meta.mkEqMP goalConduit (mkAppN recursor newMVars) mvarId.assign $ ← Meta.mkEqMP goalConduit (mkAppN recursor newMVars)
newMVars := newMVars ++ [goalConduit] newMVars := newMVars ++ [goalConduit]
let nextGoals := newMVars.toList.map (·.mvarId!) return newMVars.toList.map (λ mvar => { mvarId := mvar.mvarId!})
pure nextGoals
Elab.Tactic.setGoals nextGoals def evalMotivatedApply : Elab.Tactic.Tactic := fun stx => Elab.Tactic.withMainContext do
let recursor ← Elab.Term.elabTerm (stx := stx) .none
let nextGoals ← motivatedApply (← Elab.Tactic.getMainGoal) recursor
Elab.Tactic.setGoals $ nextGoals.map (·.mvarId)
end Pantograph.Tactic end Pantograph.Tactic

View File

@ -4,15 +4,19 @@ open Lean
namespace Pantograph.Tactic namespace Pantograph.Tactic
def noConfuse: Elab.Tactic.Tactic := λ stx => do def noConfuse (mvarId: MVarId) (h: Expr): MetaM Unit := mvarId.withContext do
let goal ← Elab.Tactic.getMainGoal mvarId.checkNotAssigned `Pantograph.Tactic.noConfuse
goal.withContext do let target ← mvarId.getType
let absurd ← Elab.Term.elabTerm (stx := stx) .none let noConfusion ← Meta.mkNoConfusion (target := target) (h := h)
let noConfusion ← Meta.mkNoConfusion (target := ← goal.getType) (h := absurd)
unless ← Meta.isDefEq (← Meta.inferType noConfusion) (← goal.getType) do unless ← Meta.isDefEq (← Meta.inferType noConfusion) target do
throwError "invalid noConfuse call: The resultant type {← Meta.ppExpr $ ← Meta.inferType noConfusion} cannot be unified with {← Meta.ppExpr $ ← goal.getType}" throwError "invalid noConfuse call: The resultant type {← Meta.ppExpr $ ← Meta.inferType noConfusion} cannot be unified with {← Meta.ppExpr target}"
goal.assign noConfusion mvarId.assign noConfusion
def evalNoConfuse: Elab.Tactic.Tactic := λ stx => do
let goal ← Elab.Tactic.getMainGoal
let h ← goal.withContext $ Elab.Term.elabTerm (stx := stx) .none
noConfuse goal h
Elab.Tactic.setGoals [] Elab.Tactic.setGoals []
end Pantograph.Tactic end Pantograph.Tactic

View File

@ -12,7 +12,7 @@ def test_congr_arg_list : TestT Elab.TermElabM Unit := do
let expr ← parseSentence expr let expr ← parseSentence expr
Meta.lambdaTelescope expr $ λ _ body => do Meta.lambdaTelescope expr $ λ _ body => do
let target ← Meta.mkFreshExprSyntheticOpaqueMVar body let target ← Meta.mkFreshExprSyntheticOpaqueMVar body
let newGoals ← runTacticOnMVar Tactic.congruenceArg target.mvarId! let newGoals ← runTacticOnMVar Tactic.evalCongruenceArg target.mvarId!
addTest $ LSpec.check "goals" ((← newGoals.mapM (λ x => mvarUserNameAndType x)) = addTest $ LSpec.check "goals" ((← newGoals.mapM (λ x => mvarUserNameAndType x)) =
[ [
(`α, "Sort ?u.30"), (`α, "Sort ?u.30"),
@ -34,7 +34,7 @@ def test_congr_arg : TestT Elab.TermElabM Unit := do
let expr ← parseSentence expr let expr ← parseSentence expr
Meta.lambdaTelescope expr $ λ _ body => do Meta.lambdaTelescope expr $ λ _ body => do
let target ← Meta.mkFreshExprSyntheticOpaqueMVar body let target ← Meta.mkFreshExprSyntheticOpaqueMVar body
let newGoals ← runTacticOnMVar Tactic.congruenceArg target.mvarId! let newGoals ← runTacticOnMVar Tactic.evalCongruenceArg target.mvarId!
addTest $ LSpec.check "goals" ((← newGoals.mapM (λ x => mvarUserNameAndType x)) = addTest $ LSpec.check "goals" ((← newGoals.mapM (λ x => mvarUserNameAndType x)) =
[ [
(`α, "Sort ?u.70"), (`α, "Sort ?u.70"),
@ -49,7 +49,7 @@ def test_congr_fun : TestT Elab.TermElabM Unit := do
let expr ← parseSentence expr let expr ← parseSentence expr
Meta.lambdaTelescope expr $ λ _ body => do Meta.lambdaTelescope expr $ λ _ body => do
let target ← Meta.mkFreshExprSyntheticOpaqueMVar body let target ← Meta.mkFreshExprSyntheticOpaqueMVar body
let newGoals ← runTacticOnMVar Tactic.congruenceFun target.mvarId! let newGoals ← runTacticOnMVar Tactic.evalCongruenceFun target.mvarId!
addTest $ LSpec.check "goals" ((← newGoals.mapM (λ x => mvarUserNameAndType x)) = addTest $ LSpec.check "goals" ((← newGoals.mapM (λ x => mvarUserNameAndType x)) =
[ [
(`α, "Sort ?u.159"), (`α, "Sort ?u.159"),
@ -64,7 +64,7 @@ def test_congr : TestT Elab.TermElabM Unit := do
let expr ← parseSentence expr let expr ← parseSentence expr
Meta.lambdaTelescope expr $ λ _ body => do Meta.lambdaTelescope expr $ λ _ body => do
let target ← Meta.mkFreshExprSyntheticOpaqueMVar body let target ← Meta.mkFreshExprSyntheticOpaqueMVar body
let newGoals ← runTacticOnMVar Tactic.congruence target.mvarId! let newGoals ← runTacticOnMVar Tactic.evalCongruence target.mvarId!
addTest $ LSpec.check "goals" ((← newGoals.mapM (λ x => mvarUserNameAndType x)) = addTest $ LSpec.check "goals" ((← newGoals.mapM (λ x => mvarUserNameAndType x)) =
[ [
(`α, "Sort ?u.10"), (`α, "Sort ?u.10"),

View File

@ -33,7 +33,7 @@ def test_nat_brec_on : TestT Elab.TermElabM Unit := do
| .error error => throwError "Failed to parse: {error}" | .error error => throwError "Failed to parse: {error}"
-- Apply the tactic -- Apply the tactic
let target ← Meta.mkFreshExprSyntheticOpaqueMVar body let target ← Meta.mkFreshExprSyntheticOpaqueMVar body
let tactic := Tactic.motivatedApply recursor let tactic := Tactic.evalMotivatedApply recursor
let newGoals ← runTacticOnMVar tactic target.mvarId! let newGoals ← runTacticOnMVar tactic target.mvarId!
let test := LSpec.check "goals" ((← newGoals.mapM (λ g => do exprToStr (← g.getType))) = let test := LSpec.check "goals" ((← newGoals.mapM (λ g => do exprToStr (← g.getType))) =
[ [
@ -57,7 +57,7 @@ def test_list_brec_on : TestT Elab.TermElabM Unit := do
| .error error => throwError "Failed to parse: {error}" | .error error => throwError "Failed to parse: {error}"
-- Apply the tactic -- Apply the tactic
let target ← Meta.mkFreshExprSyntheticOpaqueMVar body let target ← Meta.mkFreshExprSyntheticOpaqueMVar body
let tactic := Tactic.motivatedApply recursor let tactic := Tactic.evalMotivatedApply recursor
let newGoals ← runTacticOnMVar tactic target.mvarId! let newGoals ← runTacticOnMVar tactic target.mvarId!
addTest $ LSpec.check "goals" ((← newGoals.mapM (λ g => do exprToStr (← g.getType))) = addTest $ LSpec.check "goals" ((← newGoals.mapM (λ g => do exprToStr (← g.getType))) =
[ [
@ -81,7 +81,7 @@ def test_partial_motive_instantiation : TestT Elab.TermElabM Unit := do
Meta.lambdaTelescope expr $ λ _ body => do Meta.lambdaTelescope expr $ λ _ body => do
-- Apply the tactic -- Apply the tactic
let target ← Meta.mkFreshExprSyntheticOpaqueMVar body let target ← Meta.mkFreshExprSyntheticOpaqueMVar body
let tactic := Tactic.motivatedApply recursor let tactic := Tactic.evalMotivatedApply recursor
let newGoals ← runTacticOnMVar tactic target.mvarId! let newGoals ← runTacticOnMVar tactic target.mvarId!
let majorId := 67 let majorId := 67
addTest $ (LSpec.check "goals" ((← newGoals.mapM (λ g => do exprToStr (← g.getType))) = addTest $ (LSpec.check "goals" ((← newGoals.mapM (λ g => do exprToStr (← g.getType))) =

View File

@ -20,7 +20,7 @@ def test_nat : TestT Elab.TermElabM Unit := do
| .error error => throwError "Failed to parse: {error}" | .error error => throwError "Failed to parse: {error}"
-- Apply the tactic -- Apply the tactic
let target ← Meta.mkFreshExprSyntheticOpaqueMVar body let target ← Meta.mkFreshExprSyntheticOpaqueMVar body
let tactic := Tactic.noConfuse recursor let tactic := Tactic.evalNoConfuse recursor
let newGoals ← runTacticOnMVar tactic target.mvarId! let newGoals ← runTacticOnMVar tactic target.mvarId!
addTest $ LSpec.check "goals" ((← newGoals.mapM (λ g => do exprToStr (← g.getType))) = []) addTest $ LSpec.check "goals" ((← newGoals.mapM (λ g => do exprToStr (← g.getType))) = [])
@ -38,7 +38,7 @@ def test_nat_fail : TestT Elab.TermElabM Unit := do
-- Apply the tactic -- Apply the tactic
let target ← Meta.mkFreshExprSyntheticOpaqueMVar body let target ← Meta.mkFreshExprSyntheticOpaqueMVar body
try try
let tactic := Tactic.noConfuse recursor let tactic := Tactic.evalNoConfuse recursor
let _ ← runTacticOnMVar tactic target.mvarId! let _ ← runTacticOnMVar tactic target.mvarId!
addTest $ assertUnreachable "Tactic should fail" addTest $ assertUnreachable "Tactic should fail"
catch _ => catch _ =>
@ -57,7 +57,7 @@ def test_list : TestT Elab.TermElabM Unit := do
| .error error => throwError "Failed to parse: {error}" | .error error => throwError "Failed to parse: {error}"
-- Apply the tactic -- Apply the tactic
let target ← Meta.mkFreshExprSyntheticOpaqueMVar body let target ← Meta.mkFreshExprSyntheticOpaqueMVar body
let tactic := Tactic.noConfuse recursor let tactic := Tactic.evalNoConfuse recursor
let newGoals ← runTacticOnMVar tactic target.mvarId! let newGoals ← runTacticOnMVar tactic target.mvarId!
addTest $ LSpec.check "goals" addTest $ LSpec.check "goals"
((← newGoals.mapM (λ g => do exprToStr (← g.getType))) = []) ((← newGoals.mapM (λ g => do exprToStr (← g.getType))) = [])