diff --git a/Pantograph/Serial.lean b/Pantograph/Serial.lean index 14a4002..a95180e 100644 --- a/Pantograph/Serial.lean +++ b/Pantograph/Serial.lean @@ -101,6 +101,26 @@ partial def serializeSortLevel (level: Level) (sanitize: Bool): String := | _, .zero => s!"{k}" | _, _ => s!"(+ {u_str} {k})" +structure DelayedMVarInvocation where + mvarIdPending: MVarId + args: Array (FVarId × Expr) + tail: Array Expr + +def toDelayedMVarInvocation (e: Expr): MetaM (Option DelayedMVarInvocation) := do + let .mvar mvarId := e.getAppFn | return .none + let .some decl ← getDelayedMVarAssignment? mvarId | return .none + let mvarIdPending := decl.mvarIdPending + -- Print the function application e. See Lean's `withOverApp` + let args := e.getAppArgs + + assert! args.size >= decl.fvars.size + + return .some { + mvarIdPending, + args := decl.fvars.map (·.fvarId!) |>.zip args, + tail := args.toList.drop decl.fvars.size |>.toArray, + } + /-- Completely serializes an expression tree. Json not used due to compactness @@ -111,30 +131,19 @@ partial def serializeExpressionSexp (expr: Expr) (sanitize: Bool := true): MetaM self expr where delayedMVarToSexp (e: Expr): MetaM (Option String) := do - let .mvar mvarId := e.getAppFn | return .none - let .some decl ← getDelayedMVarAssignment? mvarId | return .none - let mvarIdPending := decl.mvarIdPending - -- Print the function application e. See Lean's `withOverApp` - let args := e.getAppArgs - - -- Not enough arguments to instantiate this - if args.size < decl.fvars.size then - return .none - - let callee ← self $ ← instantiateMVars $ .mvar mvarIdPending - let sites ← - decl.fvars.zip args |>.mapM (λ (fvar, arg) => do - let fvarName := Expr.fvarId! fvar |>.name - return s!"({toString fvarName} {← self arg})" + let .some invocation ← toDelayedMVarInvocation e | return .none + let callee ← self $ ← instantiateMVars $ .mvar invocation.mvarIdPending + let sites ← invocation.args.mapM (λ (fvar, arg) => do + pure s!"({toString fvar.name} {← self arg})" ) - let tailArgs ← args.toList.drop decl.fvars.size |>.mapM self + let tailArgs ← invocation.tail.mapM self let sites := " ".intercalate sites.toList let result := if tailArgs.isEmpty then s!"(:subst {callee} {sites})" else - let tailArgs := " ".intercalate tailArgs + let tailArgs := " ".intercalate tailArgs.toList s!"((:subst {callee} {sites}) {tailArgs})" return .some result diff --git a/Test/Proofs.lean b/Test/Proofs.lean index 0d31273..54b5016 100644 --- a/Test/Proofs.lean +++ b/Test/Proofs.lean @@ -748,10 +748,11 @@ def test_nat_zero_add_alt: TestM Unit := do | other => do addTest $ assertUnreachable $ other.toString return () + let major := "_uniq.68" addTest $ LSpec.check s!"mapply {recursor}" ((← state2.serializeGoals (options := ← read)).map (·.devolatilizeVars) = #[ buildNamedGoal "_uniq.67" [("n", "Nat")] "Nat → Prop" (.some "motive"), - buildNamedGoal "_uniq.68" [("n", "Nat")] "Nat", + buildNamedGoal major [("n", "Nat")] "Nat", buildNamedGoal "_uniq.69" [("n", "Nat")] "∀ (t : Nat), Nat.below t → ?motive t", buildNamedGoal "_uniq.70" [("n", "Nat")] "?motive ?m.68 = (n + 0 = n)" (.some "conduit") ]) @@ -770,7 +771,8 @@ def test_nat_zero_add_alt: TestM Unit := do | other => do addTest $ assertUnreachable $ other.toString return () - addTest $ LSpec.check tactic $ state3m2.goals.map (·.name.toString) = ["_uniq.85", "_uniq.86", "_uniq.84"] + let (eqL, eqR, eqT) := ("_uniq.85", "_uniq.86", "_uniq.84") + addTest $ LSpec.check tactic $ state3m2.goals.map (·.name.toString) = [eqL, eqR, eqT] let [_motive, _major, _step, conduit] := state2.goals | panic! "Goals conflict" let state2b ← match state3m2.resume [conduit] with | .ok state => pure state @@ -788,7 +790,7 @@ def test_nat_zero_add_alt: TestM Unit := do userName? := .some "conduit", target := { pp? := .some "?m.79 ?m.68 = (n + 0 = n)", - sexp? := .some s!"((:c Eq) (:sort 0) (:subst ((:c Eq) (:mv _uniq.84) (:mv _uniq.85) (:mv _uniq.86)) (_uniq.77 (:mv _uniq.68))) ((:c Eq) (:c Nat) ({cNatAdd} (:fv {fvN}) {cNat0}) (:fv {fvN})))", + sexp? := .some s!"((:c Eq) (:sort 0) (:subst ((:c Eq) (:mv {eqT}) (:mv {eqL}) (:mv {eqR})) (_uniq.77 (:mv {major}))) ((:c Eq) (:c Nat) ({cNatAdd} (:fv {fvN}) {cNat0}) (:fv {fvN})))", }, vars := #[{ name := fvN,