Compare commits

..

3 Commits

18 changed files with 666 additions and 728 deletions

View File

@ -1,5 +1,4 @@
import Pantograph.Delate import Pantograph.Condensed
import Pantograph.Elab
import Pantograph.Environment import Pantograph.Environment
import Pantograph.Frontend import Pantograph.Frontend
import Pantograph.Goal import Pantograph.Goal

95
Pantograph/Condensed.lean Normal file
View File

@ -0,0 +1,95 @@
/- structures for FFI based interface -/
import Lean
import Pantograph.Goal
import Pantograph.Expr
open Lean
namespace Pantograph
namespace Condensed
-- Mirrors Lean's LocalDecl
structure LocalDecl where
-- Default value is for testing
fvarId: FVarId := { name := .anonymous }
userName: Name
-- Normalized expression
type : Expr
value? : Option Expr := .none
structure Goal where
mvarId: MVarId := { name := .anonymous }
userName: Name := .anonymous
context: Array LocalDecl
target: Expr
@[export pantograph_goal_is_lhs]
def isLHS (g: Goal) : Bool := isLHSGoal? g.target |>.isSome
-- Functions for creating contexts and states
@[export pantograph_elab_context]
def elabContext: Elab.Term.Context := {
errToSorry := false
}
end Condensed
-- Get the list of visible (by default) free variables from a goal
@[export pantograph_visible_fvars_of_mvar]
protected def visibleFVarsOfMVar (mctx: MetavarContext) (mvarId: MVarId): Option (Array FVarId) := do
let mvarDecl ← mctx.findDecl? mvarId
let lctx := mvarDecl.lctx
return lctx.decls.foldl (init := #[]) fun r decl? => match decl? with
| some decl => if decl.isAuxDecl decl.isImplementationDetail then r else r.push decl.fvarId
| none => r
@[export pantograph_to_condensed_goal_m]
def toCondensedGoal (mvarId: MVarId): MetaM Condensed.Goal := do
let ppAuxDecls := Meta.pp.auxDecls.get (← getOptions)
let ppImplDetailHyps := Meta.pp.implementationDetailHyps.get (← getOptions)
let mvarDecl ← mvarId.getDecl
let lctx := mvarDecl.lctx
let lctx := lctx.sanitizeNames.run' { options := (← getOptions) }
Meta.withLCtx lctx mvarDecl.localInstances do
let ppVar (localDecl : LocalDecl) : MetaM Condensed.LocalDecl := do
match localDecl with
| .cdecl _ fvarId userName type _ _ =>
let type ← instantiate type
return { fvarId, userName, type }
| .ldecl _ fvarId userName type value _ _ => do
let userName := userName.simpMacroScopes
let type ← instantiate type
let value ← instantiate value
return { fvarId, userName, type, value? := .some value }
let vars ← lctx.foldlM (init := []) fun acc (localDecl : LocalDecl) => do
let skip := !ppAuxDecls && localDecl.isAuxDecl ||
!ppImplDetailHyps && localDecl.isImplementationDetail
if skip then
return acc
else
let var ← ppVar localDecl
return var::acc
return {
mvarId,
userName := mvarDecl.userName,
context := vars.reverse.toArray,
target := ← instantiate mvarDecl.type
}
where
instantiate := instantiateAll
@[export pantograph_goal_state_to_condensed_m]
protected def GoalState.toCondensed (state: GoalState):
CoreM (Array Condensed.Goal):= do
let metaM := do
let goals := state.goals.toArray
goals.mapM fun goal => do
match state.mctx.findDecl? goal with
| .some _ =>
let serializedGoal ← toCondensedGoal goal
pure serializedGoal
| .none => throwError s!"Metavariable does not exist in context {goal.name}"
metaM.run' (s := state.savedState.term.meta.meta)
end Pantograph

View File

@ -1,562 +0,0 @@
/-
This file handles "Delation": The conversion of Kernel view into Search view.
-/
import Lean
import Std.Data.HashMap
import Pantograph.Goal
import Pantograph.Protocol
open Lean
-- Symbol processing functions --
namespace Pantograph
structure ProjectionApplication where
projector: Name
numParams: Nat
inner: Expr
@[export pantograph_expr_proj_to_app]
def exprProjToApp (env: Environment) (e: Expr): ProjectionApplication :=
let (typeName, idx, inner) := match e with
| .proj typeName idx inner => (typeName, idx, inner)
| _ => panic! "Argument must be proj"
let ctor := getStructureCtor env typeName
let fieldName := getStructureFields env typeName |>.get! idx
let projector := getProjFnForField? env typeName fieldName |>.get!
{
projector,
numParams := ctor.numParams,
inner,
}
def _root_.Lean.Name.isAuxLemma (n : Lean.Name) : Bool := n matches .num (.str _ "_auxLemma") _
/-- Unfold all lemmas created by `Lean.Meta.mkAuxLemma`. These end in `_auxLemma.nn` where `nn` is a number. -/
@[export pantograph_unfold_aux_lemmas]
def unfoldAuxLemmas (e : Expr) : CoreM Expr := do
Lean.Meta.deltaExpand e Lean.Name.isAuxLemma
/--
Force the instantiation of delayed metavariables even if they cannot be fully
instantiated. This is used during resumption to provide diagnostic data about
the current goal.
Since Lean 4 does not have an `Expr` constructor corresponding to delayed
metavariables, any delayed metavariables must be recursively handled by this
function to ensure that nested delayed metavariables can be properly processed.
The caveat is this recursive call will lead to infinite recursion if a loop
between metavariable assignment exists.
This function ensures any metavariable in the result is either
1. Delayed assigned with its pending mvar not assigned in any form
2. Not assigned (delay or not)
-/
partial def instantiateDelayedMVars (eOrig: Expr) : MetaM Expr := do
--let padding := String.join $ List.replicate level "│ "
--IO.println s!"{padding}Starting {toString eOrig}"
let mut result ← Meta.transform (← instantiateMVars eOrig)
(pre := fun e => e.withApp fun f args => do
let .mvar mvarId := f | return .continue
--IO.println s!"{padding}├V {e}"
let mvarDecl ← mvarId.getDecl
-- This is critical to maintaining the interdependency of metavariables.
-- Without setting `.syntheticOpaque`, Lean's metavariable elimination
-- system will not make the necessary delayed assigned mvars in case of
-- nested mvars.
mvarId.setKind .syntheticOpaque
mvarId.withContext do
let lctx ← MonadLCtx.getLCtx
if mvarDecl.lctx.any (λ decl => !lctx.contains decl.fvarId) then
let violations := mvarDecl.lctx.decls.foldl (λ acc decl? => match decl? with
| .some decl => if lctx.contains decl.fvarId then acc else acc ++ [decl.fvarId.name]
| .none => acc) []
panic! s!"In the context of {mvarId.name}, there are local context variable violations: {violations}"
if let .some assign ← getExprMVarAssignment? mvarId then
--IO.println s!"{padding}├A ?{mvarId.name}"
assert! !(← mvarId.isDelayedAssigned)
return .visit (mkAppN assign args)
else if let some { fvars, mvarIdPending } ← getDelayedMVarAssignment? mvarId then
--let substTableStr := String.intercalate ", " $ Array.zipWith fvars args (λ fvar assign => s!"{fvar.fvarId!.name} := {assign}") |>.toList
--IO.println s!"{padding}├MD ?{mvarId.name} := ?{mvarIdPending.name} [{substTableStr}]"
if args.size < fvars.size then
throwError "Not enough arguments to instantiate a delay assigned mvar. This is due to bad implementations of a tactic: {args.size} < {fvars.size}. Expr: {toString e}; Origin: {toString eOrig}"
--if !args.isEmpty then
--IO.println s!"{padding}├── Arguments Begin"
let args ← args.mapM self
--if !args.isEmpty then
--IO.println s!"{padding}├── Arguments End"
if !(← mvarIdPending.isAssignedOrDelayedAssigned) then
--IO.println s!"{padding}├T1"
let result := mkAppN f args
return .done result
let pending ← mvarIdPending.withContext do
let inner ← instantiateDelayedMVars (.mvar mvarIdPending) --(level := level + 1)
--IO.println s!"{padding}├Pre: {inner}"
pure <| (← inner.abstractM fvars).instantiateRev args
-- Tail arguments
let result := mkAppRange pending fvars.size args.size args
--IO.println s!"{padding}├MD {result}"
return .done result
else
assert! !(← mvarId.isAssigned)
assert! !(← mvarId.isDelayedAssigned)
--if !args.isEmpty then
-- IO.println s!"{padding}├── Arguments Begin"
let args ← args.mapM self
--if !args.isEmpty then
-- IO.println s!"{padding}├── Arguments End"
--IO.println s!"{padding}├M ?{mvarId.name}"
return .done (mkAppN f args))
--IO.println s!"{padding}└Result {result}"
return result
where
self e := instantiateDelayedMVars e --(level := level + 1)
/--
Convert an expression to an equiavlent form with
1. No nested delayed assigned mvars
2. No aux lemmas
3. No assigned mvars
-/
@[export pantograph_instantiate_all_m]
def instantiateAll (e: Expr): MetaM Expr := do
let e ← instantiateDelayedMVars e
let e ← unfoldAuxLemmas e
return e
structure DelayedMVarInvocation where
mvarIdPending: MVarId
args: Array (FVarId × (Option Expr))
-- Extra arguments applied to the result of this substitution
tail: Array Expr
-- The pending mvar of any delayed assigned mvar must not be assigned in any way.
@[export pantograph_to_delayed_mvar_invocation_m]
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
let mvarDecl ← mvarIdPending.getDecl
-- Print the function application e. See Lean's `withOverApp`
let args := e.getAppArgs
assert! args.size ≥ decl.fvars.size
assert! !(← mvarIdPending.isAssigned)
assert! !(← mvarIdPending.isDelayedAssigned)
let fvarArgMap: Std.HashMap FVarId Expr := Std.HashMap.ofList $ (decl.fvars.map (·.fvarId!) |>.zip args).toList
let subst ← mvarDecl.lctx.foldlM (init := []) λ acc localDecl => do
let fvarId := localDecl.fvarId
let a := fvarArgMap[fvarId]?
return acc ++ [(fvarId, a)]
assert! decl.fvars.all (λ fvar => mvarDecl.lctx.findFVar? fvar |>.isSome)
return .some {
mvarIdPending,
args := subst.toArray,
tail := args.toList.drop decl.fvars.size |>.toArray,
}
-- Condensed representation
namespace Condensed
-- Mirrors Lean's LocalDecl
structure LocalDecl where
-- Default value is for testing
fvarId: FVarId := { name := .anonymous }
userName: Name
-- Normalized expression
type : Expr
value? : Option Expr := .none
structure Goal where
mvarId: MVarId := { name := .anonymous }
userName: Name := .anonymous
context: Array LocalDecl
target: Expr
@[export pantograph_goal_is_lhs]
def isLHS (g: Goal) : Bool := isLHSGoal? g.target |>.isSome
end Condensed
-- Get the list of visible (by default) free variables from a goal
@[export pantograph_visible_fvars_of_mvar]
protected def visibleFVarsOfMVar (mctx: MetavarContext) (mvarId: MVarId): Option (Array FVarId) := do
let mvarDecl ← mctx.findDecl? mvarId
let lctx := mvarDecl.lctx
return lctx.decls.foldl (init := #[]) fun r decl? => match decl? with
| some decl => if decl.isAuxDecl decl.isImplementationDetail then r else r.push decl.fvarId
| none => r
@[export pantograph_to_condensed_goal_m]
def toCondensedGoal (mvarId: MVarId): MetaM Condensed.Goal := do
let ppAuxDecls := Meta.pp.auxDecls.get (← getOptions)
let ppImplDetailHyps := Meta.pp.implementationDetailHyps.get (← getOptions)
let mvarDecl ← mvarId.getDecl
let lctx := mvarDecl.lctx
let lctx := lctx.sanitizeNames.run' { options := (← getOptions) }
Meta.withLCtx lctx mvarDecl.localInstances do
let ppVar (localDecl : LocalDecl) : MetaM Condensed.LocalDecl := do
match localDecl with
| .cdecl _ fvarId userName type _ _ =>
let type ← instantiate type
return { fvarId, userName, type }
| .ldecl _ fvarId userName type value _ _ => do
let userName := userName.simpMacroScopes
let type ← instantiate type
let value ← instantiate value
return { fvarId, userName, type, value? := .some value }
let vars ← lctx.foldlM (init := []) fun acc (localDecl : LocalDecl) => do
let skip := !ppAuxDecls && localDecl.isAuxDecl ||
!ppImplDetailHyps && localDecl.isImplementationDetail
if skip then
return acc
else
let var ← ppVar localDecl
return var::acc
return {
mvarId,
userName := mvarDecl.userName,
context := vars.reverse.toArray,
target := ← instantiate mvarDecl.type
}
where
instantiate := instantiateAll
@[export pantograph_goal_state_to_condensed_m]
protected def GoalState.toCondensed (state: GoalState):
CoreM (Array Condensed.Goal):= do
let metaM := do
let goals := state.goals.toArray
goals.mapM fun goal => do
match state.mctx.findDecl? goal with
| .some _ =>
let serializedGoal ← toCondensedGoal goal
pure serializedGoal
| .none => throwError s!"Metavariable does not exist in context {goal.name}"
metaM.run' (s := state.savedState.term.meta.meta)
def typeExprToBound (expr: Expr): MetaM Protocol.BoundExpression := do
Meta.forallTelescope expr fun arr body => do
let binders ← arr.mapM fun fvar => do
return (toString (← fvar.fvarId!.getUserName), toString (← Meta.ppExpr (← fvar.fvarId!.getType)))
return { binders, target := toString (← Meta.ppExpr body) }
def serializeName (name: Name) (sanitize: Bool := true): String :=
let internal := name.isInaccessibleUserName || name.hasMacroScopes
if sanitize && internal then "_"
else toString name |> addQuotes
where
addQuotes (n: String) :=
let quote := "\""
if n.contains Lean.idBeginEscape then s!"{quote}{n}{quote}" else n
/-- serialize a sort level. Expression is optimized to be compact e.g. `(+ u 2)` -/
partial def serializeSortLevel (level: Level) (sanitize: Bool): String :=
let k := level.getOffset
let u := level.getLevelOffset
let u_str := match u with
| .zero => "0"
| .succ _ => panic! "getLevelOffset should not return .succ"
| .max v w =>
let v := serializeSortLevel v sanitize
let w := serializeSortLevel w sanitize
s!"(:max {v} {w})"
| .imax v w =>
let v := serializeSortLevel v sanitize
let w := serializeSortLevel w sanitize
s!"(:imax {v} {w})"
| .param name =>
let name := serializeName name sanitize
s!"{name}"
| .mvar id =>
let name := serializeName id.name sanitize
s!"(:mv {name})"
match k, u with
| 0, _ => u_str
| _, .zero => s!"{k}"
| _, _ => s!"(+ {u_str} {k})"
/--
Completely serializes an expression tree. Json not used due to compactness
A `_` symbol in the AST indicates automatic deductions not present in the original expression.
-/
partial def serializeExpressionSexp (expr: Expr) (sanitize: Bool := true): MetaM String := do
self expr
where
delayedMVarToSexp (e: Expr): MetaM (Option String) := do
let .some invocation ← toDelayedMVarInvocation e | return .none
let callee ← self $ .mvar invocation.mvarIdPending
let sites ← invocation.args.mapM (λ (fvarId, arg) => do
let arg := match arg with
| .some arg => arg
| .none => .fvar fvarId
self arg
)
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.toList
s!"((:subst {callee} {sites}) {tailArgs})"
return .some result
self (e: Expr): MetaM String := do
if let .some result ← delayedMVarToSexp e then
return result
match e with
| .bvar deBruijnIndex =>
-- This is very common so the index alone is shown. Literals are handled below.
-- The raw de Bruijn index should never appear in an unbound setting. In
-- Lean these are handled using a `#` prefix.
pure s!"{deBruijnIndex}"
| .fvar fvarId =>
let name := ofName fvarId.name
pure s!"(:fv {name})"
| .mvar mvarId => do
let pref := if ← mvarId.isDelayedAssigned then "mvd" else "mv"
let name := ofName mvarId.name
pure s!"(:{pref} {name})"
| .sort level =>
let level := serializeSortLevel level sanitize
pure s!"(:sort {level})"
| .const declName _ =>
-- The universe level of the const expression is elided since it should be
-- inferrable from surrounding expression
pure s!"(:c {declName})"
| .app _ _ => do
let fn' ← self e.getAppFn
let args := (← e.getAppArgs.mapM self) |>.toList
let args := " ".intercalate args
pure s!"({fn'} {args})"
| .lam binderName binderType body binderInfo => do
let binderName' := ofName binderName
let binderType' ← self binderType
let body' ← self body
let binderInfo' := binderInfoSexp binderInfo
pure s!"(:lambda {binderName'} {binderType'} {body'}{binderInfo'})"
| .forallE binderName binderType body binderInfo => do
let binderName' := ofName binderName
let binderType' ← self binderType
let body' ← self body
let binderInfo' := binderInfoSexp binderInfo
pure s!"(:forall {binderName'} {binderType'} {body'}{binderInfo'})"
| .letE name type value body _ => do
-- Dependent boolean flag diacarded
let name' := serializeName name
let type' ← self type
let value' ← self value
let body' ← self body
pure s!"(:let {name'} {type'} {value'} {body'})"
| .lit v =>
-- To not burden the downstream parser who needs to handle this, the literal
-- is wrapped in a :lit sexp.
let v' := match v with
| .natVal val => toString val
| .strVal val => s!"\"{val}\""
pure s!"(:lit {v'})"
| .mdata _ inner =>
-- NOTE: Equivalent to expr itself, but mdata influences the prettyprinter
-- It may become necessary to incorporate the metadata.
self inner
| .proj _ _ _ => do
let env ← getEnv
let projApp := exprProjToApp env e
let autos := String.intercalate " " (List.replicate projApp.numParams "_")
let inner ← self projApp.inner
pure s!"((:c {projApp.projector}) {autos} {inner})"
-- Elides all unhygenic names
binderInfoSexp : Lean.BinderInfo → String
| .default => ""
| .implicit => " :implicit"
| .strictImplicit => " :strictImplicit"
| .instImplicit => " :instImplicit"
ofName (name: Name) := serializeName name sanitize
def serializeExpression (options: @&Protocol.Options) (e: Expr): MetaM Protocol.Expression := do
let pp?: Option String ← match options.printExprPretty with
| true => pure $ .some $ toString $ ← Meta.ppExpr e
| false => pure $ .none
let sexp?: Option String ← match options.printExprAST with
| true => pure $ .some $ ← serializeExpressionSexp e
| false => pure $ .none
let dependentMVars? ← match options.printDependentMVars with
| true => pure $ .some $ (← Meta.getMVars e).map (λ mvarId => mvarId.name.toString)
| false => pure $ .none
return {
pp?,
sexp?
dependentMVars?,
}
/-- Adapted from ppGoal -/
def serializeGoal (options: @&Protocol.Options) (goal: MVarId) (mvarDecl: MetavarDecl) (parentDecl?: Option MetavarDecl := .none)
: MetaM Protocol.Goal := do
-- Options for printing; See Meta.ppGoal for details
let showLetValues := true
let ppAuxDecls := options.printAuxDecls
let ppImplDetailHyps := options.printImplementationDetailHyps
let lctx := mvarDecl.lctx
let lctx := lctx.sanitizeNames.run' { options := (← getOptions) }
Meta.withLCtx lctx mvarDecl.localInstances do
let ppVarNameOnly (localDecl: LocalDecl): MetaM Protocol.Variable := do
match localDecl with
| .cdecl _ fvarId userName _ _ _ =>
return {
name := ofName fvarId.name,
userName:= ofName userName.simpMacroScopes,
isInaccessible := userName.isInaccessibleUserName
}
| .ldecl _ fvarId userName _ _ _ _ => do
return {
name := ofName fvarId.name,
userName := toString userName.simpMacroScopes,
isInaccessible := userName.isInaccessibleUserName
}
let ppVar (localDecl : LocalDecl) : MetaM Protocol.Variable := do
match localDecl with
| .cdecl _ fvarId userName type _ _ =>
let userName := userName.simpMacroScopes
let type ← instantiate type
return {
name := ofName fvarId.name,
userName:= ofName userName,
isInaccessible := userName.isInaccessibleUserName
type? := .some (← serializeExpression options type)
}
| .ldecl _ fvarId userName type val _ _ => do
let userName := userName.simpMacroScopes
let type ← instantiate type
let value? ← if showLetValues then
let val ← instantiate val
pure $ .some (← serializeExpression options val)
else
pure $ .none
return {
name := ofName fvarId.name,
userName:= ofName userName,
isInaccessible := userName.isInaccessibleUserName
type? := .some (← serializeExpression options type)
value? := value?
}
let vars ← lctx.foldlM (init := []) fun acc (localDecl : LocalDecl) => do
let skip := !ppAuxDecls && localDecl.isAuxDecl ||
!ppImplDetailHyps && localDecl.isImplementationDetail
if skip then
return acc
else
let nameOnly := options.noRepeat && (parentDecl?.map
(λ decl => decl.lctx.find? localDecl.fvarId |>.isSome) |>.getD false)
let var ← match nameOnly with
| true => ppVarNameOnly localDecl
| false => ppVar localDecl
return var::acc
return {
name := ofName goal.name,
userName? := if mvarDecl.userName == .anonymous then .none else .some (ofName mvarDecl.userName),
isConversion := isLHSGoal? mvarDecl.type |>.isSome,
target := (← serializeExpression options (← instantiate mvarDecl.type)),
vars := vars.reverse.toArray
}
where
instantiate := instantiateAll
ofName (n: Name) := serializeName n (sanitize := false)
protected def GoalState.serializeGoals
(state: GoalState)
(parent: Option GoalState := .none)
(options: @&Protocol.Options := {}):
MetaM (Array Protocol.Goal):= do
state.restoreMetaM
let goals := state.goals.toArray
let parentDecl? := parent.bind (λ parentState => parentState.mctx.findDecl? state.parentMVar?.get!)
goals.mapM fun goal => do
match state.mctx.findDecl? goal with
| .some mvarDecl =>
let serializedGoal ← serializeGoal options goal mvarDecl (parentDecl? := parentDecl?)
pure serializedGoal
| .none => throwError s!"Metavariable does not exist in context {goal.name}"
/-- Print the metavariables in a readable format -/
@[export pantograph_goal_state_diag_m]
protected def GoalState.diag (goalState: GoalState) (parent?: Option GoalState := .none) (options: Protocol.GoalDiag := {}): CoreM String := do
let metaM: MetaM String := do
goalState.restoreMetaM
let savedState := goalState.savedState
let goals := savedState.tactic.goals
let mctx ← getMCtx
let root := goalState.root
-- Print the root
let result: String ← match mctx.decls.find? root with
| .some decl => printMVar ">" root decl
| .none => pure s!">{root.name}: ??"
let resultGoals ← goals.filter (· != root) |>.mapM (fun mvarId =>
match mctx.decls.find? mvarId with
| .some decl => printMVar "⊢" mvarId decl
| .none => pure s!"⊢{mvarId.name}: ??"
)
let goals := goals.toSSet
let resultOthers ← mctx.decls.toList.filter (λ (mvarId, _) =>
!(goals.contains mvarId || mvarId == root) && options.printAll)
|>.mapM (fun (mvarId, decl) => do
let pref := if parentHasMVar mvarId then " " else "~"
printMVar pref mvarId decl
)
pure $ result ++ "\n" ++ (resultGoals.map (· ++ "\n") |> String.join) ++ (resultOthers.map (· ++ "\n") |> String.join)
metaM.run' {}
where
printMVar (pref: String) (mvarId: MVarId) (decl: MetavarDecl): MetaM String := mvarId.withContext do
let resultFVars: List String ←
if options.printContext then
decl.lctx.fvarIdToDecl.toList.mapM (λ (fvarId, decl) =>
do pure $ (← printFVar fvarId decl) ++ "\n")
else
pure []
let type ← if options.instantiate
then instantiateAll decl.type
else pure $ decl.type
let type_sexp ← if options.printSexp then
let sexp ← serializeExpressionSexp type (sanitize := false)
pure <| " " ++ sexp
else
pure ""
let resultMain: String := s!"{pref}{mvarId.name}{userNameToString decl.userName}: {← Meta.ppExpr decl.type}{type_sexp}"
let resultValue: String ←
if options.printValue then
if let .some value ← getExprMVarAssignment? mvarId then
let value ← if options.instantiate
then instantiateAll value
else pure $ value
pure s!"\n := {← Meta.ppExpr value}"
else if let .some { mvarIdPending, .. } ← getDelayedMVarAssignment? mvarId then
pure s!"\n ::= {mvarIdPending.name}"
else
pure ""
else
pure ""
pure $ (String.join resultFVars) ++ resultMain ++ resultValue
printFVar (fvarId: FVarId) (decl: LocalDecl): MetaM String := do
pure s!" | {fvarId.name}{userNameToString decl.userName}: {← Meta.ppExpr decl.type}"
userNameToString : Name → String
| .anonymous => ""
| other => s!"[{other}]"
parentHasMVar (mvarId: MVarId): Bool := parent?.map (λ state => state.mctx.decls.contains mvarId) |>.getD true
end Pantograph

View File

@ -1,40 +0,0 @@
import Lean
open Lean
namespace Pantograph
-- Functions for creating contexts and states
@[export pantograph_default_elab_context]
def defaultElabContext: Elab.Term.Context := {
errToSorry := false
}
/-- Read syntax object from string -/
def parseTerm (env: Environment) (s: String): Except String Syntax :=
Parser.runParserCategory
(env := env)
(catName := `term)
(input := s)
(fileName := "<stdin>")
def parseTermM [Monad m] [MonadEnv m] (s: String): m (Except String Syntax) := do
return Parser.runParserCategory
(env := ← MonadEnv.getEnv)
(catName := `term)
(input := s)
(fileName := "<stdin>")
/-- Parse a syntax object. May generate additional metavariables! -/
def elabType (syn: Syntax): Elab.TermElabM (Except String Expr) := do
try
let expr ← Elab.Term.elabType syn
return .ok expr
catch ex => return .error (← ex.toMessageData.toString)
def elabTerm (syn: Syntax) (expectedType? : Option Expr := .none): Elab.TermElabM (Except String Expr) := do
try
let expr ← Elab.Term.elabTerm (stx := syn) expectedType?
return .ok expr
catch ex => return .error (← ex.toMessageData.toString)
end Pantograph

View File

@ -1,9 +1,6 @@
import Pantograph.Delate
import Pantograph.Elab
import Pantograph.Protocol import Pantograph.Protocol
import Pantograph.Serial import Pantograph.Serial
import Lean.Environment import Lean
import Lean.Replay
open Lean open Lean
open Pantograph open Pantograph

162
Pantograph/Expr.lean Normal file
View File

@ -0,0 +1,162 @@
import Lean
import Std.Data.HashMap
open Lean
namespace Pantograph
structure ProjectionApplication where
projector: Name
numParams: Nat
inner: Expr
@[export pantograph_expr_proj_to_app]
def exprProjToApp (env: Environment) (e: Expr): ProjectionApplication :=
let (typeName, idx, inner) := match e with
| .proj typeName idx inner => (typeName, idx, inner)
| _ => panic! "Argument must be proj"
let ctor := getStructureCtor env typeName
let fieldName := getStructureFields env typeName |>.get! idx
let projector := getProjFnForField? env typeName fieldName |>.get!
{
projector,
numParams := ctor.numParams,
inner,
}
def _root_.Lean.Name.isAuxLemma (n : Lean.Name) : Bool := n matches .num (.str _ "_auxLemma") _
/-- Unfold all lemmas created by `Lean.Meta.mkAuxLemma`. These end in `_auxLemma.nn` where `nn` is a number. -/
@[export pantograph_unfold_aux_lemmas]
def unfoldAuxLemmas (e : Expr) : CoreM Expr := do
Lean.Meta.deltaExpand e Lean.Name.isAuxLemma
/--
Force the instantiation of delayed metavariables even if they cannot be fully
instantiated. This is used during resumption to provide diagnostic data about
the current goal.
Since Lean 4 does not have an `Expr` constructor corresponding to delayed
metavariables, any delayed metavariables must be recursively handled by this
function to ensure that nested delayed metavariables can be properly processed.
The caveat is this recursive call will lead to infinite recursion if a loop
between metavariable assignment exists.
This function ensures any metavariable in the result is either
1. Delayed assigned with its pending mvar not assigned in any form
2. Not assigned (delay or not)
-/
partial def instantiateDelayedMVars (eOrig: Expr) : MetaM Expr := do
--let padding := String.join $ List.replicate level "│ "
--IO.println s!"{padding}Starting {toString eOrig}"
let mut result ← Meta.transform (← instantiateMVars eOrig)
(pre := fun e => e.withApp fun f args => do
let .mvar mvarId := f | return .continue
--IO.println s!"{padding}├V {e}"
let mvarDecl ← mvarId.getDecl
-- This is critical to maintaining the interdependency of metavariables.
-- Without setting `.syntheticOpaque`, Lean's metavariable elimination
-- system will not make the necessary delayed assigned mvars in case of
-- nested mvars.
mvarId.setKind .syntheticOpaque
mvarId.withContext do
let lctx ← MonadLCtx.getLCtx
if mvarDecl.lctx.any (λ decl => !lctx.contains decl.fvarId) then
let violations := mvarDecl.lctx.decls.foldl (λ acc decl? => match decl? with
| .some decl => if lctx.contains decl.fvarId then acc else acc ++ [decl.fvarId.name]
| .none => acc) []
panic! s!"In the context of {mvarId.name}, there are local context variable violations: {violations}"
if let .some assign ← getExprMVarAssignment? mvarId then
--IO.println s!"{padding}├A ?{mvarId.name}"
assert! !(← mvarId.isDelayedAssigned)
return .visit (mkAppN assign args)
else if let some { fvars, mvarIdPending } ← getDelayedMVarAssignment? mvarId then
--let substTableStr := String.intercalate ", " $ Array.zipWith fvars args (λ fvar assign => s!"{fvar.fvarId!.name} := {assign}") |>.toList
--IO.println s!"{padding}├MD ?{mvarId.name} := ?{mvarIdPending.name} [{substTableStr}]"
if args.size < fvars.size then
throwError "Not enough arguments to instantiate a delay assigned mvar. This is due to bad implementations of a tactic: {args.size} < {fvars.size}. Expr: {toString e}; Origin: {toString eOrig}"
--if !args.isEmpty then
--IO.println s!"{padding}├── Arguments Begin"
let args ← args.mapM self
--if !args.isEmpty then
--IO.println s!"{padding}├── Arguments End"
if !(← mvarIdPending.isAssignedOrDelayedAssigned) then
--IO.println s!"{padding}├T1"
let result := mkAppN f args
return .done result
let pending ← mvarIdPending.withContext do
let inner ← instantiateDelayedMVars (.mvar mvarIdPending) --(level := level + 1)
--IO.println s!"{padding}├Pre: {inner}"
pure <| (← inner.abstractM fvars).instantiateRev args
-- Tail arguments
let result := mkAppRange pending fvars.size args.size args
--IO.println s!"{padding}├MD {result}"
return .done result
else
assert! !(← mvarId.isAssigned)
assert! !(← mvarId.isDelayedAssigned)
--if !args.isEmpty then
-- IO.println s!"{padding}├── Arguments Begin"
let args ← args.mapM self
--if !args.isEmpty then
-- IO.println s!"{padding}├── Arguments End"
--IO.println s!"{padding}├M ?{mvarId.name}"
return .done (mkAppN f args))
--IO.println s!"{padding}└Result {result}"
return result
where
self e := instantiateDelayedMVars e --(level := level + 1)
/--
Convert an expression to an equiavlent form with
1. No nested delayed assigned mvars
2. No aux lemmas
3. No assigned mvars
-/
@[export pantograph_instantiate_all_m]
def instantiateAll (e: Expr): MetaM Expr := do
let e ← instantiateDelayedMVars e
let e ← unfoldAuxLemmas e
return e
structure DelayedMVarInvocation where
mvarIdPending: MVarId
args: Array (FVarId × (Option Expr))
-- Extra arguments applied to the result of this substitution
tail: Array Expr
-- The pending mvar of any delayed assigned mvar must not be assigned in any way.
@[export pantograph_to_delayed_mvar_invocation_m]
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
let mvarDecl ← mvarIdPending.getDecl
-- Print the function application e. See Lean's `withOverApp`
let args := e.getAppArgs
assert! args.size ≥ decl.fvars.size
assert! !(← mvarIdPending.isAssigned)
assert! !(← mvarIdPending.isDelayedAssigned)
let fvarArgMap: Std.HashMap FVarId Expr := Std.HashMap.ofList $ (decl.fvars.map (·.fvarId!) |>.zip args).toList
let subst ← mvarDecl.lctx.foldlM (init := []) λ acc localDecl => do
let fvarId := localDecl.fvarId
let a := fvarArgMap[fvarId]?
return acc ++ [(fvarId, a)]
assert! decl.fvars.all (λ fvar => mvarDecl.lctx.findFVar? fvar |>.isSome)
return .some {
mvarIdPending,
args := subst.toArray,
tail := args.toList.drop decl.fvars.size |>.toArray,
}
end Pantograph

View File

@ -122,6 +122,13 @@ protected def goalStateAfter (t : TacticInvocation) : IO (List Format) := do
protected def ppExpr (t : TacticInvocation) (e : Expr) : IO Format := protected def ppExpr (t : TacticInvocation) (e : Expr) : IO Format :=
t.runMetaM (fun _ => do Meta.ppExpr (← instantiateMVars e)) t.runMetaM (fun _ => do Meta.ppExpr (← instantiateMVars e))
protected def usedConstants (t: TacticInvocation) : NameSet :=
let info := t.info
info.goalsBefore
|>.filterMap info.mctxAfter.getExprAssignmentCore?
|>.map Expr.getUsedConstantsAsSet
|>.foldl .union .empty
end TacticInvocation end TacticInvocation
/-- Analogue of `Lean.Elab.InfoTree.findInfo?`, but that returns a list of all results. -/ /-- Analogue of `Lean.Elab.InfoTree.findInfo?`, but that returns a list of all results. -/
@ -158,7 +165,13 @@ def collectTacticsFromCompilationStep (step : CompilationStep) : IO (List Protoc
let tactic ← invocation.ctx.runMetaM {} do let tactic ← invocation.ctx.runMetaM {} do
let t ← PrettyPrinter.ppTactic ⟨invocation.info.stx⟩ let t ← PrettyPrinter.ppTactic ⟨invocation.info.stx⟩
return t.pretty return t.pretty
return { goalBefore, goalAfter, tactic } let usedConstants := invocation.usedConstants.toArray.map λ n => n.toString
return {
goalBefore,
goalAfter,
tactic,
usedConstants,
}
structure InfoWithContext where structure InfoWithContext where
info: Elab.Info info: Elab.Info

View File

@ -1,7 +1,8 @@
import Pantograph.Condensed
import Pantograph.Environment import Pantograph.Environment
import Pantograph.Goal import Pantograph.Goal
import Pantograph.Protocol import Pantograph.Protocol
import Pantograph.Delate import Pantograph.Serial
import Pantograph.Version import Pantograph.Version
import Lean import Lean
@ -41,7 +42,7 @@ namespace Pantograph
def runMetaM { α } (metaM: MetaM α): CoreM α := def runMetaM { α } (metaM: MetaM α): CoreM α :=
metaM.run' metaM.run'
def runTermElabM { α } (termElabM: Elab.TermElabM α): CoreM α := def runTermElabM { α } (termElabM: Elab.TermElabM α): CoreM α :=
termElabM.run' (ctx := defaultElabContext) |>.run' termElabM.run' (ctx := Condensed.elabContext) |>.run'
def errorI (type desc: String): Protocol.InteractionError := { error := type, desc := desc } def errorI (type desc: String): Protocol.InteractionError := { error := type, desc := desc }

View File

@ -183,12 +183,6 @@ structure EnvAdd where
structure EnvAddResult where structure EnvAddResult where
deriving Lean.ToJson deriving Lean.ToJson
structure EnvSaveLoad where
path: System.FilePath
deriving Lean.FromJson
structure EnvSaveLoadResult where
deriving Lean.ToJson
/-- Set options; See `Options` struct above for meanings -/ /-- Set options; See `Options` struct above for meanings -/
structure OptionsSet where structure OptionsSet where
printJsonPretty?: Option Bool printJsonPretty?: Option Bool
@ -304,6 +298,9 @@ structure InvokedTactic where
goalBefore: String goalBefore: String
goalAfter: String goalAfter: String
tactic: String tactic: String
-- List of used constants
usedConstants: Array String
deriving Lean.ToJson deriving Lean.ToJson
structure CompilationUnit where structure CompilationUnit where

View File

@ -1,73 +1,362 @@
import Lean.Environment /-
import Lean.Replay All serialisation functions;
import Init.System.IOError This replicates the behaviour of `Scope`s in `Lean/Elab/Command.lean` without
import Std.Data.HashMap using `Scope`s.
/-!
Input/Output functions
# Pickling and unpickling objects
By abusing `saveModuleData` and `readModuleData` we can pickle and unpickle objects to disk.
-/ -/
import Lean
import Pantograph.Condensed
import Pantograph.Expr
import Pantograph.Goal
import Pantograph.Protocol
open Lean open Lean
-- Symbol processing functions --
namespace Pantograph namespace Pantograph
/--
Save an object to disk. --- Input Functions ---
If you need to write multiple objects from within a single declaration,
you will need to provide a unique `key` for each. /-- Read syntax object from string -/
-/ def parseTerm (env: Environment) (s: String): Except String Syntax :=
def pickle {α : Type} (path : System.FilePath) (x : α) (key : Name := by exact decl_name%) : IO Unit := Parser.runParserCategory
saveModuleData path key (unsafe unsafeCast x) (env := env)
(catName := `term)
(input := s)
(fileName := "<stdin>")
def parseTermM [Monad m] [MonadEnv m] (s: String): m (Except String Syntax) := do
return Parser.runParserCategory
(env := ← MonadEnv.getEnv)
(catName := `term)
(input := s)
(fileName := "<stdin>")
/-- Parse a syntax object. May generate additional metavariables! -/
def elabType (syn: Syntax): Elab.TermElabM (Except String Expr) := do
try
let expr ← Elab.Term.elabType syn
return .ok expr
catch ex => return .error (← ex.toMessageData.toString)
def elabTerm (syn: Syntax) (expectedType? : Option Expr := .none): Elab.TermElabM (Except String Expr) := do
try
let expr ← Elab.Term.elabTerm (stx := syn) expectedType?
return .ok expr
catch ex => return .error (← ex.toMessageData.toString)
--- Output Functions ---
def typeExprToBound (expr: Expr): MetaM Protocol.BoundExpression := do
Meta.forallTelescope expr fun arr body => do
let binders ← arr.mapM fun fvar => do
return (toString (← fvar.fvarId!.getUserName), toString (← Meta.ppExpr (← fvar.fvarId!.getType)))
return { binders, target := toString (← Meta.ppExpr body) }
def serializeName (name: Name) (sanitize: Bool := true): String :=
let internal := name.isInaccessibleUserName || name.hasMacroScopes
if sanitize && internal then "_"
else toString name |> addQuotes
where
addQuotes (n: String) :=
let quote := "\""
if n.contains Lean.idBeginEscape then s!"{quote}{n}{quote}" else n
/-- serialize a sort level. Expression is optimized to be compact e.g. `(+ u 2)` -/
partial def serializeSortLevel (level: Level) (sanitize: Bool): String :=
let k := level.getOffset
let u := level.getLevelOffset
let u_str := match u with
| .zero => "0"
| .succ _ => panic! "getLevelOffset should not return .succ"
| .max v w =>
let v := serializeSortLevel v sanitize
let w := serializeSortLevel w sanitize
s!"(:max {v} {w})"
| .imax v w =>
let v := serializeSortLevel v sanitize
let w := serializeSortLevel w sanitize
s!"(:imax {v} {w})"
| .param name =>
let name := serializeName name sanitize
s!"{name}"
| .mvar id =>
let name := serializeName id.name sanitize
s!"(:mv {name})"
match k, u with
| 0, _ => u_str
| _, .zero => s!"{k}"
| _, _ => s!"(+ {u_str} {k})"
/-- /--
Load an object from disk. Completely serializes an expression tree. Json not used due to compactness
Note: The returned `CompactedRegion` can be used to free the memory behind the value
of type `α`, using `CompactedRegion.free` (which is only safe once all references to the `α` are
released). Ignoring the `CompactedRegion` results in the data being leaked.
Use `withUnpickle` to call `CompactedRegion.free` automatically.
This function is unsafe because the data being loaded may not actually have type `α`, and this A `_` symbol in the AST indicates automatic deductions not present in the original expression.
may cause crashes or other bad behavior.
-/ -/
unsafe def unpickle (α : Type) (path : System.FilePath) : IO (α × CompactedRegion) := do partial def serializeExpressionSexp (expr: Expr) (sanitize: Bool := true): MetaM String := do
let (x, region) ← readModuleData path self expr
pure (unsafeCast x, region) where
delayedMVarToSexp (e: Expr): MetaM (Option String) := do
let .some invocation ← toDelayedMVarInvocation e | return .none
let callee ← self $ .mvar invocation.mvarIdPending
let sites ← invocation.args.mapM (λ (fvarId, arg) => do
let arg := match arg with
| .some arg => arg
| .none => .fvar fvarId
self arg
)
let tailArgs ← invocation.tail.mapM self
/-- Load an object from disk and run some continuation on it, freeing memory afterwards. -/ let sites := " ".intercalate sites.toList
unsafe def withUnpickle [Monad m] [MonadLiftT IO m] {α β : Type} let result := if tailArgs.isEmpty then
(path : System.FilePath) (f : α → m β) : m β := do s!"(:subst {callee} {sites})"
let (x, region) ← unpickle α path else
let r ← f x let tailArgs := " ".intercalate tailArgs.toList
region.free s!"((:subst {callee} {sites}) {tailArgs})"
pure r return .some result
/-- self (e: Expr): MetaM String := do
Pickle an `Environment` to disk. if let .some result ← delayedMVarToSexp e then
return result
match e with
| .bvar deBruijnIndex =>
-- This is very common so the index alone is shown. Literals are handled below.
-- The raw de Bruijn index should never appear in an unbound setting. In
-- Lean these are handled using a `#` prefix.
pure s!"{deBruijnIndex}"
| .fvar fvarId =>
let name := ofName fvarId.name
pure s!"(:fv {name})"
| .mvar mvarId => do
let pref := if ← mvarId.isDelayedAssigned then "mvd" else "mv"
let name := ofName mvarId.name
pure s!"(:{pref} {name})"
| .sort level =>
let level := serializeSortLevel level sanitize
pure s!"(:sort {level})"
| .const declName _ =>
-- The universe level of the const expression is elided since it should be
-- inferrable from surrounding expression
pure s!"(:c {declName})"
| .app _ _ => do
let fn' ← self e.getAppFn
let args := (← e.getAppArgs.mapM self) |>.toList
let args := " ".intercalate args
pure s!"({fn'} {args})"
| .lam binderName binderType body binderInfo => do
let binderName' := ofName binderName
let binderType' ← self binderType
let body' ← self body
let binderInfo' := binderInfoSexp binderInfo
pure s!"(:lambda {binderName'} {binderType'} {body'}{binderInfo'})"
| .forallE binderName binderType body binderInfo => do
let binderName' := ofName binderName
let binderType' ← self binderType
let body' ← self body
let binderInfo' := binderInfoSexp binderInfo
pure s!"(:forall {binderName'} {binderType'} {body'}{binderInfo'})"
| .letE name type value body _ => do
-- Dependent boolean flag diacarded
let name' := serializeName name
let type' ← self type
let value' ← self value
let body' ← self body
pure s!"(:let {name'} {type'} {value'} {body'})"
| .lit v =>
-- To not burden the downstream parser who needs to handle this, the literal
-- is wrapped in a :lit sexp.
let v' := match v with
| .natVal val => toString val
| .strVal val => s!"\"{val}\""
pure s!"(:lit {v'})"
| .mdata _ inner =>
-- NOTE: Equivalent to expr itself, but mdata influences the prettyprinter
-- It may become necessary to incorporate the metadata.
self inner
| .proj _ _ _ => do
let env ← getEnv
let projApp := exprProjToApp env e
let autos := String.intercalate " " (List.replicate projApp.numParams "_")
let inner ← self projApp.inner
pure s!"((:c {projApp.projector}) {autos} {inner})"
-- Elides all unhygenic names
binderInfoSexp : Lean.BinderInfo → String
| .default => ""
| .implicit => " :implicit"
| .strictImplicit => " :strictImplicit"
| .instImplicit => " :instImplicit"
ofName (name: Name) := serializeName name sanitize
We only store: def serializeExpression (options: @&Protocol.Options) (e: Expr): MetaM Protocol.Expression := do
* the list of imports let pp?: Option String ← match options.printExprPretty with
* the new constants from `Environment.constants` | true => pure $ .some $ toString $ ← Meta.ppExpr e
and when unpickling, we build a fresh `Environment` from the imports, | false => pure $ .none
and then add the new constants. let sexp?: Option String ← match options.printExprAST with
-/ | true => pure $ .some $ ← serializeExpressionSexp e
@[export pantograph_env_pickle_m] | false => pure $ .none
def env_pickle (env : Environment) (path : System.FilePath) : IO Unit := let dependentMVars? ← match options.printDependentMVars with
Pantograph.pickle path (env.header.imports, env.constants.map₂) | true => pure $ .some $ (← Meta.getMVars e).map (λ mvarId => mvarId.name.toString)
| false => pure $ .none
return {
pp?,
sexp?
dependentMVars?,
}
/--
Unpickle an `Environment` from disk.
We construct a fresh `Environment` with the relevant imports, /-- Adapted from ppGoal -/
and then replace the new constants. def serializeGoal (options: @&Protocol.Options) (goal: MVarId) (mvarDecl: MetavarDecl) (parentDecl?: Option MetavarDecl := .none)
-/ : MetaM Protocol.Goal := do
@[export pantograph_env_unpickle_m] -- Options for printing; See Meta.ppGoal for details
def env_unpickle (path : System.FilePath) : IO (Environment × CompactedRegion) := unsafe do let showLetValues := true
let ((imports, map₂), region) ← Pantograph.unpickle (Array Import × PHashMap Name ConstantInfo) path let ppAuxDecls := options.printAuxDecls
let env ← importModules imports {} 0 let ppImplDetailHyps := options.printImplementationDetailHyps
return (← env.replay (Std.HashMap.ofList map₂.toList), region) let lctx := mvarDecl.lctx
let lctx := lctx.sanitizeNames.run' { options := (← getOptions) }
Meta.withLCtx lctx mvarDecl.localInstances do
let ppVarNameOnly (localDecl: LocalDecl): MetaM Protocol.Variable := do
match localDecl with
| .cdecl _ fvarId userName _ _ _ =>
return {
name := ofName fvarId.name,
userName:= ofName userName.simpMacroScopes,
isInaccessible := userName.isInaccessibleUserName
}
| .ldecl _ fvarId userName _ _ _ _ => do
return {
name := ofName fvarId.name,
userName := toString userName.simpMacroScopes,
isInaccessible := userName.isInaccessibleUserName
}
let ppVar (localDecl : LocalDecl) : MetaM Protocol.Variable := do
match localDecl with
| .cdecl _ fvarId userName type _ _ =>
let userName := userName.simpMacroScopes
let type ← instantiate type
return {
name := ofName fvarId.name,
userName:= ofName userName,
isInaccessible := userName.isInaccessibleUserName
type? := .some (← serializeExpression options type)
}
| .ldecl _ fvarId userName type val _ _ => do
let userName := userName.simpMacroScopes
let type ← instantiate type
let value? ← if showLetValues then
let val ← instantiate val
pure $ .some (← serializeExpression options val)
else
pure $ .none
return {
name := ofName fvarId.name,
userName:= ofName userName,
isInaccessible := userName.isInaccessibleUserName
type? := .some (← serializeExpression options type)
value? := value?
}
let vars ← lctx.foldlM (init := []) fun acc (localDecl : LocalDecl) => do
let skip := !ppAuxDecls && localDecl.isAuxDecl ||
!ppImplDetailHyps && localDecl.isImplementationDetail
if skip then
return acc
else
let nameOnly := options.noRepeat && (parentDecl?.map
(λ decl => decl.lctx.find? localDecl.fvarId |>.isSome) |>.getD false)
let var ← match nameOnly with
| true => ppVarNameOnly localDecl
| false => ppVar localDecl
return var::acc
return {
name := ofName goal.name,
userName? := if mvarDecl.userName == .anonymous then .none else .some (ofName mvarDecl.userName),
isConversion := isLHSGoal? mvarDecl.type |>.isSome,
target := (← serializeExpression options (← instantiate mvarDecl.type)),
vars := vars.reverse.toArray
}
where
instantiate := instantiateAll
ofName (n: Name) := serializeName n (sanitize := false)
protected def GoalState.serializeGoals
(state: GoalState)
(parent: Option GoalState := .none)
(options: @&Protocol.Options := {}):
MetaM (Array Protocol.Goal):= do
state.restoreMetaM
let goals := state.goals.toArray
let parentDecl? := parent.bind (λ parentState => parentState.mctx.findDecl? state.parentMVar?.get!)
goals.mapM fun goal => do
match state.mctx.findDecl? goal with
| .some mvarDecl =>
let serializedGoal ← serializeGoal options goal mvarDecl (parentDecl? := parentDecl?)
pure serializedGoal
| .none => throwError s!"Metavariable does not exist in context {goal.name}"
/-- Print the metavariables in a readable format -/
@[export pantograph_goal_state_diag_m]
protected def GoalState.diag (goalState: GoalState) (parent?: Option GoalState := .none) (options: Protocol.GoalDiag := {}): CoreM String := do
let metaM: MetaM String := do
goalState.restoreMetaM
let savedState := goalState.savedState
let goals := savedState.tactic.goals
let mctx ← getMCtx
let root := goalState.root
-- Print the root
let result: String ← match mctx.decls.find? root with
| .some decl => printMVar ">" root decl
| .none => pure s!">{root.name}: ??"
let resultGoals ← goals.filter (· != root) |>.mapM (fun mvarId =>
match mctx.decls.find? mvarId with
| .some decl => printMVar "⊢" mvarId decl
| .none => pure s!"⊢{mvarId.name}: ??"
)
let goals := goals.toSSet
let resultOthers ← mctx.decls.toList.filter (λ (mvarId, _) =>
!(goals.contains mvarId || mvarId == root) && options.printAll)
|>.mapM (fun (mvarId, decl) => do
let pref := if parentHasMVar mvarId then " " else "~"
printMVar pref mvarId decl
)
pure $ result ++ "\n" ++ (resultGoals.map (· ++ "\n") |> String.join) ++ (resultOthers.map (· ++ "\n") |> String.join)
metaM.run' {}
where
printMVar (pref: String) (mvarId: MVarId) (decl: MetavarDecl): MetaM String := mvarId.withContext do
let resultFVars: List String ←
if options.printContext then
decl.lctx.fvarIdToDecl.toList.mapM (λ (fvarId, decl) =>
do pure $ (← printFVar fvarId decl) ++ "\n")
else
pure []
let type ← if options.instantiate
then instantiateAll decl.type
else pure $ decl.type
let type_sexp ← if options.printSexp then
let sexp ← serializeExpressionSexp type (sanitize := false)
pure <| " " ++ sexp
else
pure ""
let resultMain: String := s!"{pref}{mvarId.name}{userNameToString decl.userName}: {← Meta.ppExpr decl.type}{type_sexp}"
let resultValue: String ←
if options.printValue then
if let .some value ← getExprMVarAssignment? mvarId then
let value ← if options.instantiate
then instantiateAll value
else pure $ value
pure s!"\n := {← Meta.ppExpr value}"
else if let .some { mvarIdPending, .. } ← getDelayedMVarAssignment? mvarId then
pure s!"\n ::= {mvarIdPending.name}"
else
pure ""
else
pure ""
pure $ (String.join resultFVars) ++ resultMain ++ resultValue
printFVar (fvarId: FVarId) (decl: LocalDecl): MetaM String := do
pure s!" | {fvarId.name}{userNameToString decl.userName}: {← Meta.ppExpr decl.type}"
userNameToString : Name → String
| .anonymous => ""
| other => s!"[{other}]"
parentHasMVar (mvarId: MVarId): Bool := parent?.map (λ state => state.mctx.decls.contains mvarId) |>.getD true
end Pantograph end Pantograph

View File

@ -22,9 +22,8 @@ abbrev CR α := Except Protocol.InteractionError α
def runMetaInMainM { α } (metaM: Lean.MetaM α): MainM α := def runMetaInMainM { α } (metaM: Lean.MetaM α): MainM α :=
metaM.run' metaM.run'
def runTermElabInMainM { α } (termElabM: Lean.Elab.TermElabM α) : MainM α := def runTermElabInMainM { α } (termElabM: Lean.Elab.TermElabM α) : MainM α :=
termElabM.run' (ctx := defaultElabContext) |>.run' termElabM.run' (ctx := Condensed.elabContext) |>.run'
/-- Main loop command of the REPL -/
def execute (command: Protocol.Command): MainM Lean.Json := do def execute (command: Protocol.Command): MainM Lean.Json := do
let run { α β: Type } [Lean.FromJson α] [Lean.ToJson β] (comm: α → MainM (CR β)): MainM Lean.Json := let run { α β: Type } [Lean.FromJson α] [Lean.ToJson β] (comm: α → MainM (CR β)): MainM Lean.Json :=
match Lean.fromJson? command.payload with match Lean.fromJson? command.payload with
@ -33,35 +32,28 @@ def execute (command: Protocol.Command): MainM Lean.Json := do
| .ok result => return Lean.toJson result | .ok result => return Lean.toJson result
| .error ierror => return Lean.toJson ierror | .error ierror => return Lean.toJson ierror
| .error error => return Lean.toJson $ errorCommand s!"Unable to parse json: {error}" | .error error => return Lean.toJson $ errorCommand s!"Unable to parse json: {error}"
try match command.cmd with
match command.cmd with | "reset" => run reset
| "reset" => run reset | "stat" => run stat
| "stat" => run stat | "expr.echo" => run expr_echo
| "expr.echo" => run expr_echo | "env.catalog" => run env_catalog
| "env.catalog" => run env_catalog | "env.inspect" => run env_inspect
| "env.inspect" => run env_inspect | "env.add" => run env_add
| "env.add" => run env_add | "options.set" => run options_set
| "env.save" => run env_save | "options.print" => run options_print
| "env.load" => run env_load | "goal.start" => run goal_start
| "options.set" => run options_set | "goal.tactic" => run goal_tactic
| "options.print" => run options_print | "goal.continue" => run goal_continue
| "goal.start" => run goal_start | "goal.delete" => run goal_delete
| "goal.tactic" => run goal_tactic | "goal.print" => run goal_print
| "goal.continue" => run goal_continue | "frontend.process" => run frontend_process
| "goal.delete" => run goal_delete | cmd =>
| "goal.print" => run goal_print let error: Protocol.InteractionError :=
| "frontend.process" => run frontend_process errorCommand s!"Unknown command {cmd}"
| cmd => return Lean.toJson error
let error: Protocol.InteractionError :=
errorCommand s!"Unknown command {cmd}"
return Lean.toJson error
catch ex => do
let error ← ex.toMessageData.toString
return Lean.toJson $ errorIO error
where where
errorCommand := errorI "command" errorCommand := errorI "command"
errorIndex := errorI "index" errorIndex := errorI "index"
errorIO := errorI "io"
newGoalState (goalState: GoalState) : MainM Nat := do newGoalState (goalState: GoalState) : MainM Nat := do
let state ← get let state ← get
let stateId := state.nextId let stateId := state.nextId
@ -88,14 +80,6 @@ def execute (command: Protocol.Command): MainM Lean.Json := do
Environment.inspect args state.options Environment.inspect args state.options
env_add (args: Protocol.EnvAdd): MainM (CR Protocol.EnvAddResult) := do env_add (args: Protocol.EnvAdd): MainM (CR Protocol.EnvAddResult) := do
Environment.addDecl args Environment.addDecl args
env_save (args: Protocol.EnvSaveLoad): MainM (CR Protocol.EnvSaveLoadResult) := do
let env ← Lean.MonadEnv.getEnv
env_pickle env args.path
return .ok {}
env_load (args: Protocol.EnvSaveLoad): MainM (CR Protocol.EnvSaveLoadResult) := do
let (env, _) ← env_unpickle args.path
Lean.setEnv env
return .ok {}
expr_echo (args: Protocol.ExprEcho): MainM (CR Protocol.ExprEchoResult) := do expr_echo (args: Protocol.ExprEcho): MainM (CR Protocol.ExprEchoResult) := do
let state ← get let state ← get
exprEcho args.expr (expectedType? := args.type?) (levels := args.levels.getD #[]) (options := state.options) exprEcho args.expr (expectedType? := args.type?) (levels := args.levels.getD #[]) (options := state.options)

View File

@ -1,6 +1,7 @@
import Pantograph.Goal import Pantograph.Goal
import Pantograph.Library import Pantograph.Library
import Pantograph.Protocol import Pantograph.Protocol
import Pantograph.Condensed
import Lean import Lean
import LSpec import LSpec
@ -89,9 +90,9 @@ def runCoreMSeq (env: Environment) (coreM: CoreM LSpec.TestSeq) (options: Array
def runMetaMSeq (env: Environment) (metaM: MetaM LSpec.TestSeq): IO LSpec.TestSeq := def runMetaMSeq (env: Environment) (metaM: MetaM LSpec.TestSeq): IO LSpec.TestSeq :=
runCoreMSeq env metaM.run' runCoreMSeq env metaM.run'
def runTermElabMInMeta { α } (termElabM: Lean.Elab.TermElabM α): Lean.MetaM α := def runTermElabMInMeta { α } (termElabM: Lean.Elab.TermElabM α): Lean.MetaM α :=
termElabM.run' (ctx := defaultElabContext) termElabM.run' (ctx := Condensed.elabContext)
def runTermElabMSeq (env: Environment) (termElabM: Elab.TermElabM LSpec.TestSeq): IO LSpec.TestSeq := def runTermElabMSeq (env: Environment) (termElabM: Elab.TermElabM LSpec.TestSeq): IO LSpec.TestSeq :=
runMetaMSeq env $ termElabM.run' (ctx := defaultElabContext) runMetaMSeq env $ termElabM.run' (ctx := Condensed.elabContext)
def exprToStr (e: Expr): Lean.MetaM String := toString <$> Meta.ppExpr e def exprToStr (e: Expr): Lean.MetaM String := toString <$> Meta.ppExpr e

View File

@ -1,5 +1,5 @@
import LSpec import LSpec
import Pantograph.Delate import Pantograph.Serial
import Pantograph.Environment import Pantograph.Environment
import Test.Common import Test.Common
import Lean import Lean

View File

@ -167,8 +167,8 @@ example : ∀ (p: Prop), p → p := by
def test_frontend_process : Test := def test_frontend_process : Test :=
[ [
let file := "example : ∀ (p: Prop), p → p := by\n intro p h\n exact h" let file := "example : ∀ (p q: Prop), p → p q := by\n intro p q h\n exact Or.inl h"
let goal1 := "p : Prop\nh : p\n⊢ p" let goal1 := "p q : Prop\nh : p\n⊢ p q"
step "frontend.process" step "frontend.process"
[ [
("file", .str file), ("file", .str file),
@ -180,14 +180,16 @@ def test_frontend_process : Test :=
boundary := (0, file.utf8ByteSize), boundary := (0, file.utf8ByteSize),
invocations? := .some [ invocations? := .some [
{ {
goalBefore := "⊢ ∀ (p : Prop), p → p", goalBefore := "⊢ ∀ (p q : Prop), p → p q",
goalAfter := goal1, goalAfter := goal1,
tactic := "intro p h", tactic := "intro p q h",
usedConstants := #[],
}, },
{ {
goalBefore := goal1 , goalBefore := goal1 ,
goalAfter := "", goalAfter := "",
tactic := "exact h", tactic := "exact Or.inl h",
usedConstants := #["Or.inl"],
}, },
] ]
}], }],

View File

@ -5,7 +5,7 @@ import Test.Integration
import Test.Library import Test.Library
import Test.Metavar import Test.Metavar
import Test.Proofs import Test.Proofs
import Test.Delate import Test.Serial
import Test.Tactic import Test.Tactic
-- Test running infrastructure -- Test running infrastructure
@ -50,7 +50,7 @@ def main (args: List String) := do
("Library", Library.suite env_default), ("Library", Library.suite env_default),
("Metavar", Metavar.suite env_default), ("Metavar", Metavar.suite env_default),
("Proofs", Proofs.suite env_default), ("Proofs", Proofs.suite env_default),
("Delate", Delate.suite env_default), ("Serial", Serial.suite env_default),
("Tactic/Congruence", Tactic.Congruence.suite env_default), ("Tactic/Congruence", Tactic.Congruence.suite env_default),
("Tactic/Motivated Apply", Tactic.MotivatedApply.suite env_default), ("Tactic/Motivated Apply", Tactic.MotivatedApply.suite env_default),
("Tactic/No Confuse", Tactic.NoConfuse.suite env_default), ("Tactic/No Confuse", Tactic.NoConfuse.suite env_default),

View File

@ -1,6 +1,6 @@
import LSpec import LSpec
import Pantograph.Goal import Pantograph.Goal
import Pantograph.Delate import Pantograph.Serial
import Test.Common import Test.Common
import Lean import Lean
@ -66,7 +66,7 @@ def proofRunner (env: Lean.Environment) (tests: TestM Unit): IO LSpec.TestSeq :=
let termElabM := tests.run LSpec.TestSeq.done |>.run {} -- with default options let termElabM := tests.run LSpec.TestSeq.done |>.run {} -- with default options
let coreContext: Lean.Core.Context ← createCoreContext #[] let coreContext: Lean.Core.Context ← createCoreContext #[]
let metaM := termElabM.run' (ctx := defaultElabContext) let metaM := termElabM.run' (ctx := Condensed.elabContext)
let coreM := metaM.run' let coreM := metaM.run'
match ← (coreM.run' coreContext { env := env }).toBaseIO with match ← (coreM.run' coreContext { env := env }).toBaseIO with
| .error exception => | .error exception =>

View File

@ -3,7 +3,7 @@ Tests pertaining to goals with no interdependencies
-/ -/
import LSpec import LSpec
import Pantograph.Goal import Pantograph.Goal
import Pantograph.Delate import Pantograph.Serial
import Test.Common import Test.Common
namespace Pantograph.Test.Proofs namespace Pantograph.Test.Proofs
@ -74,7 +74,7 @@ def proofRunner (env: Lean.Environment) (tests: TestM Unit): IO LSpec.TestSeq :=
let termElabM := tests.run LSpec.TestSeq.done |>.run {} -- with default options let termElabM := tests.run LSpec.TestSeq.done |>.run {} -- with default options
let coreContext: Lean.Core.Context ← createCoreContext #[] let coreContext: Lean.Core.Context ← createCoreContext #[]
let metaM := termElabM.run' (ctx := defaultElabContext) let metaM := termElabM.run' (ctx := Condensed.elabContext)
let coreM := metaM.run' let coreM := metaM.run'
match ← (coreM.run' coreContext { env := env }).toBaseIO with match ← (coreM.run' coreContext { env := env }).toBaseIO with
| .error exception => | .error exception =>

View File

@ -1,10 +1,10 @@
import LSpec import LSpec
import Pantograph.Delate import Pantograph.Serial
import Test.Common import Test.Common
import Lean import Lean
open Lean open Lean
namespace Pantograph.Test.Delate namespace Pantograph.Test.Serial
open Pantograph open Pantograph
@ -64,7 +64,7 @@ def test_sexp_of_elab (env: Environment): IO LSpec.TestSeq := do
| .ok expr => pure expr | .ok expr => pure expr
| .error e => return elabFailure e | .error e => return elabFailure e
return LSpec.check source ((← serializeExpressionSexp expr) = target) return LSpec.check source ((← serializeExpressionSexp expr) = target)
let metaM := (Elab.Term.withLevelNames levels termElabM).run' (ctx := defaultElabContext) let metaM := (Elab.Term.withLevelNames levels termElabM).run' (ctx := Condensed.elabContext)
return LSpec.TestSeq.append suites (← runMetaMSeq env metaM)) return LSpec.TestSeq.append suites (← runMetaMSeq env metaM))
LSpec.TestSeq.done LSpec.TestSeq.done
@ -85,7 +85,7 @@ def test_sexp_of_expr (env: Environment): IO LSpec.TestSeq := do
let testCaseName := target.take 10 let testCaseName := target.take 10
let test := LSpec.check testCaseName ((← serializeExpressionSexp expr) = target) let test := LSpec.check testCaseName ((← serializeExpressionSexp expr) = target)
return LSpec.TestSeq.append suites test) LSpec.TestSeq.done return LSpec.TestSeq.append suites test) LSpec.TestSeq.done
runMetaMSeq env $ termElabM.run' (ctx := defaultElabContext) runMetaMSeq env $ termElabM.run' (ctx := Condensed.elabContext)
-- Instance parsing -- Instance parsing
def test_instance (env: Environment): IO LSpec.TestSeq := def test_instance (env: Environment): IO LSpec.TestSeq :=
@ -106,4 +106,4 @@ def suite (env: Environment): List (String × IO LSpec.TestSeq) :=
("Instance", test_instance env), ("Instance", test_instance env),
] ]
end Pantograph.Test.Delate end Pantograph.Test.Serial