Add expression sexp printing (1/2, tests pending)

This commit is contained in:
Leni Aniva 2023-08-14 17:07:53 -07:00
parent d705cdf0e5
commit 19c57ada1e
7 changed files with 214 additions and 146 deletions

View File

@ -19,6 +19,36 @@ unsafe def loop : Subroutine Unit := do
IO.println <| toString <| ret IO.println <| toString <| ret
loop loop
namespace Lean
/-- This is better than the default version since it handles `.` and doesn't
crash the program when it fails. -/
def setOptionFromString' (opts : Options) (entry : String) : ExceptT String IO Options := do
let ps := (entry.splitOn "=").map String.trim
let [key, val] ← pure ps | throw "invalid configuration option entry, it must be of the form '<key> = <value>'"
let key := Pantograph.str_to_name key
let defValue ← getOptionDefaultValue key
match defValue with
| DataValue.ofString _ => pure $ opts.setString key val
| DataValue.ofBool _ =>
match val with
| "true" => pure $ opts.setBool key true
| "false" => pure $ opts.setBool key false
| _ => throw s!"invalid Bool option value '{val}'"
| DataValue.ofName _ => pure $ opts.setName key val.toName
| DataValue.ofNat _ =>
match val.toNat? with
| none => throw s!"invalid Nat option value '{val}'"
| some v => pure $ opts.setNat key v
| DataValue.ofInt _ =>
match val.toInt? with
| none => throw s!"invalid Int option value '{val}'"
| some v => pure $ opts.setInt key v
| DataValue.ofSyntax _ => throw s!"invalid Syntax option value"
end Lean
unsafe def main (args: List String): IO Unit := do unsafe def main (args: List String): IO Unit := do
-- NOTE: A more sophisticated scheme of command line argument handling is needed. -- NOTE: A more sophisticated scheme of command line argument handling is needed.
-- Separate imports and options -- Separate imports and options
@ -30,7 +60,7 @@ unsafe def main (args: List String): IO Unit := do
Lean.initSearchPath (← Lean.findSysroot) Lean.initSearchPath (← Lean.findSysroot)
let options? ← args.filterMap (λ s => if s.startsWith "--" then .some <| s.drop 2 else .none) let options? ← args.filterMap (λ s => if s.startsWith "--" then .some <| s.drop 2 else .none)
|>.foldlM Lean.setOptionFromString'' Lean.Options.empty |>.foldlM Lean.setOptionFromString' Lean.Options.empty
|>.run |>.run
let options ← match options? with let options ← match options? with
| .ok options => pure options | .ok options => pure options
@ -42,6 +72,7 @@ unsafe def main (args: List String): IO Unit := do
(opts := {}) (opts := {})
(trustLevel := 1) (trustLevel := 1)
let context: Context := { let context: Context := {
imports
} }
let coreContext: Lean.Core.Context := { let coreContext: Lean.Core.Context := {
currNamespace := Lean.Name.str .anonymous "Aniva" currNamespace := Lean.Name.str .anonymous "Aniva"

View File

@ -3,39 +3,14 @@ import Pantograph.Serial
import Pantograph.Meta import Pantograph.Meta
import Pantograph.Symbols import Pantograph.Symbols
namespace Lean
-- This is better than the default version since it handles `.` and doesn't
-- crash the program when it fails.
def setOptionFromString'' (opts : Options) (entry : String) : ExceptT String IO Options := do
let ps := (entry.splitOn "=").map String.trim
let [key, val] ← pure ps | throw "invalid configuration option entry, it must be of the form '<key> = <value>'"
let key := Pantograph.str_to_name key
let defValue ← getOptionDefaultValue key
match defValue with
| DataValue.ofString _ => pure $ opts.setString key val
| DataValue.ofBool _ =>
match val with
| "true" => pure $ opts.setBool key true
| "false" => pure $ opts.setBool key false
| _ => throw s!"invalid Bool option value '{val}'"
| DataValue.ofName _ => pure $ opts.setName key val.toName
| DataValue.ofNat _ =>
match val.toNat? with
| none => throw s!"invalid Nat option value '{val}'"
| some v => pure $ opts.setNat key v
| DataValue.ofInt _ =>
match val.toInt? with
| none => throw s!"invalid Int option value '{val}'"
| some v => pure $ opts.setInt key v
| DataValue.ofSyntax _ => throw s!"invalid Syntax option value"
end Lean
namespace Pantograph namespace Pantograph
structure Context where structure Context where
imports: List String
/-- Stores state of the REPL -/ /-- Stores state of the REPL -/
structure State where structure State where
options: Commands.Options := {}
--environments: Array Lean.Environment := #[] --environments: Array Lean.Environment := #[]
proofTrees: Array ProofTree := #[] proofTrees: Array ProofTree := #[]
@ -59,9 +34,13 @@ def parse_command (s: String): Except String Commands.Command := do
def execute (command: Commands.Command): Subroutine Lean.Json := do def execute (command: Commands.Command): Subroutine Lean.Json := do
match command.cmd with match command.cmd with
| "option.set" => | "options.set" =>
match Lean.fromJson? command.payload with match Lean.fromJson? command.payload with
| .ok args => option_set args | .ok args => options_set args
| .error x => return errorJson x
| "options.print" =>
match Lean.fromJson? command.payload with
| .ok args => options_print args
| .error x => return errorJson x | .error x => return errorJson x
| "catalog" => | "catalog" =>
match Lean.fromJson? command.payload with match Lean.fromJson? command.payload with
@ -97,16 +76,19 @@ def execute (command: Commands.Command): Subroutine Lean.Json := do
{ error := type, desc := desc }: Commands.InteractionError) { error := type, desc := desc }: Commands.InteractionError)
errorJson := errorI "json" errorJson := errorI "json"
errorIndex := errorI "index" errorIndex := errorI "index"
option_set (args: Commands.OptionSet): Subroutine Lean.Json := do -- Command Functions
let options? ← args.options.foldlM Lean.setOptionFromString'' Lean.Options.empty options_set (args: Commands.OptionsSet): Subroutine Lean.Json := do
|>.run let state ← get
match options? with set { state with
| .ok options => options := {
withTheReader Lean.Core.Context printExprPretty := args.printExprPretty?.getD true,
(λ coreContext => { coreContext with options }) printExprAST := args.printExprAST?.getD true,
(pure $ Lean.toJson <| ({ }: Commands.OptionSetResult)) proofVariableDelta := args.proofVariableDelta?.getD false
| .error e => }
return errorI "parsing" e }
return Lean.toJson ({ }: Commands.OptionsSetResult)
options_print (_: Commands.OptionsPrint): Subroutine Lean.Json := do
return Lean.toJson (← get).options
catalog (_: Commands.Catalog): Subroutine Lean.Json := do catalog (_: Commands.Catalog): Subroutine Lean.Json := do
let env ← Lean.MonadEnv.getEnv let env ← Lean.MonadEnv.getEnv
let names := env.constants.fold (init := #[]) (λ acc name info => let names := env.constants.fold (init := #[]) (λ acc name info =>
@ -115,22 +97,23 @@ def execute (command: Commands.Command): Subroutine Lean.Json := do
| .none => acc) | .none => acc)
return Lean.toJson <| ({ symbols := names }: Commands.CatalogResult) return Lean.toJson <| ({ symbols := names }: Commands.CatalogResult)
inspect (args: Commands.Inspect): Subroutine Lean.Json := do inspect (args: Commands.Inspect): Subroutine Lean.Json := do
let state ← get
let env ← Lean.MonadEnv.getEnv let env ← Lean.MonadEnv.getEnv
let name := str_to_name args.name let name := str_to_name args.name
let info? := env.find? name let info? := env.find? name
match info? with match info? with
| none => return errorIndex s!"Symbol not found {args.name}" | none => return errorIndex s!"Symbol not found {args.name}"
| some info => | some info =>
let format ← Lean.Meta.ppExpr info.toConstantVal.type
let module? := env.getModuleIdxFor? name >>= let module? := env.getModuleIdxFor? name >>=
(λ idx => env.allImportedModuleNames.get? idx.toNat) |>.map toString (λ idx => env.allImportedModuleNames.get? idx.toNat) |>.map toString
let boundExpr? ← (match info.toConstantVal.type with let value? := match args.value?, info with
| .forallE _ _ _ _ => return Option.none -- TODO: Temporary override, enable expression dissection in options. | .some true, _ => info.value?
-- return .some (← type_expr_to_bound info.toConstantVal.type) | .some false, _ => .none
| _ => return Option.none) | .none, .defnInfo _ => info.value?
| .none, _ => .none
return Lean.toJson ({ return Lean.toJson ({
type := toString format, type := ← serialize_expression state.options info.type,
boundExpr? := boundExpr?, value? := ← value?.mapM (λ v => serialize_expression state.options v),
module? := module? module? := module?
}: Commands.InspectResult) }: Commands.InspectResult)
clear : Subroutine Lean.Json := do clear : Subroutine Lean.Json := do

View File

@ -6,10 +6,55 @@ its field names to avoid confusion with error messages generated by the REPL.
-/ -/
import Lean.Data.Json import Lean.Data.Json
import Pantograph.Serial
namespace Pantograph.Commands namespace Pantograph.Commands
/-- Main Option structure, placed here to avoid name collision -/
structure Options where
-- When enabled, pretty print every expression
printExprPretty: Bool := true
-- When enabled, print the raw AST of expressions
printExprAST: Bool := false
-- When enabled, the types and values of persistent variables in a proof goal
-- are not shown unless they are new to the proof step. Reduces overhead
proofVariableDelta: Bool := false
deriving Lean.ToJson
--- Expression Objects ---
structure BoundExpression where
binders: Array (String × String)
target: String
deriving Lean.ToJson
structure Expression where
-- Pretty printed expression
pp?: Option String := .none
-- AST structure
sexp?: Option String := .none
deriving Lean.ToJson
structure Variable where
name: String
/-- Does the name contain a dagger -/
isInaccessible: Bool := false
type: Expression
value?: Option Expression := .none
deriving Lean.ToJson
structure Goal where
/-- String case id -/
caseName?: Option String := .none
/-- Is the goal in conversion mode -/
isConversion: Bool := false
/-- target expression type -/
target: Expression
/-- Variables -/
vars: Array Variable := #[]
deriving Lean.ToJson
--- Individual Commands and return types ---
structure Command where structure Command where
cmd: String cmd: String
payload: Lean.Json payload: Lean.Json
@ -23,15 +68,19 @@ structure InteractionError where
--- Individual command and return types --- --- Individual command and return types ---
-- Set Lean options supplied in the form of /-- Set options; See `Options` struct above for meanings -/
-- structure OptionsSet where
-- option=value printExprPretty?: Option Bool
structure OptionSet where printExprAST?: Option Bool
options: Array String proofVariableDelta?: Option Bool
deriving Lean.FromJson deriving Lean.FromJson
structure OptionSetResult where structure OptionsSetResult where
deriving Lean.ToJson deriving Lean.ToJson
structure OptionsPrint where
deriving Lean.FromJson
abbrev OptionsPrintResult := Options
-- Print all symbols in environment -- Print all symbols in environment
structure Catalog where structure Catalog where
@ -43,11 +92,13 @@ structure CatalogResult where
-- Print the type of a symbol -- Print the type of a symbol
structure Inspect where structure Inspect where
name: String name: String
-- If true/false, show/hide the value expressions; By default definitions
-- values are shown and theorem values are hidden.
value?: Option Bool := .some false
deriving Lean.FromJson deriving Lean.FromJson
structure InspectResult where structure InspectResult where
type: String type: Expression
-- Decompose the bound expression when the type is forall. value?: Option Expression := .none
boundExpr?: Option BoundExpression := Option.none
module?: Option String module?: Option String
deriving Lean.ToJson deriving Lean.ToJson

View File

@ -16,7 +16,9 @@ From this point on, any proof which extends
-/ -/
def Lean.MessageLog.getErrorMessages (log : MessageLog) : MessageLog := def Lean.MessageLog.getErrorMessages (log : MessageLog) : MessageLog :=
{ msgs := log.msgs.filter fun m => match m.severity with | MessageSeverity.error => true | _ => false } {
msgs := log.msgs.filter fun m => match m.severity with | MessageSeverity.error => true | _ => false
}
namespace Pantograph namespace Pantograph
@ -83,12 +85,14 @@ inductive TacticResult where
-- Invalid id -- Invalid id
| invalid (message: String): TacticResult | invalid (message: String): TacticResult
-- Goes to next state -- Goes to next state
| success (nextId?: Option Nat) (goals: Array Goal) | success (nextId?: Option Nat) (goals: Array Commands.Goal)
-- Fails with messages -- Fails with messages
| failure (messages: Array String) | failure (messages: Array String)
/-- Execute tactic on given state -/ /-- Execute tactic on given state -/
def ProofTree.execute (stateId: Nat) (goalId: Nat) (tactic: String): StateRefT ProofTree M TacticResult := do def ProofTree.execute (stateId: Nat) (goalId: Nat) (tactic: String): StateRefT ProofTree M TacticResult := do
-- TODO: Replace with actual options
let options: Commands.Options := {}
let tree ← get let tree ← get
match tree.states.get? stateId with match tree.states.get? stateId with
| .none => return .invalid s!"Invalid state id {stateId}" | .none => return .invalid s!"Invalid state id {stateId}"
@ -113,7 +117,7 @@ def ProofTree.execute (stateId: Nat) (goalId: Nat) (tactic: String): StateRefT P
modify fun s => { s with states := s.states.push proofState } modify fun s => { s with states := s.states.push proofState }
let goals ← nextGoals.mapM fun mvarId => do let goals ← nextGoals.mapM fun mvarId => do
match (← MonadMCtx.getMCtx).findDecl? mvarId with match (← MonadMCtx.getMCtx).findDecl? mvarId with
| .some mvarDecl => serialize_goal mvarDecl | .some mvarDecl => serialize_goal options mvarDecl
| .none => throwError mvarId | .none => throwError mvarId
return .success (.some nextId) goals.toArray return .success (.some nextId) goals.toArray

View File

@ -3,15 +3,20 @@ All serialisation functions
-/ -/
import Lean import Lean
import Pantograph.Commands
namespace Pantograph namespace Pantograph
open Lean open Lean
--- Input Functions ---
/-- Read a theorem from the environment -/ /-- Read a theorem from the environment -/
def expr_from_const (env: Environment) (name: Name): Except String Lean.Expr := def expr_from_const (env: Environment) (name: Name): Except String Lean.Expr :=
match env.find? name with match env.find? name with
| none => throw s!"Symbol not found: {name}" | none => throw s!"Symbol not found: {name}"
| some cInfo => return cInfo.type | some cInfo => return cInfo.type
/-- Read syntax object from string -/
def syntax_from_str (env: Environment) (s: String): Except String Syntax := def syntax_from_str (env: Environment) (s: String): Except String Syntax :=
Parser.runParserCategory Parser.runParserCategory
(env := env) (env := env)
@ -39,84 +44,15 @@ def syntax_to_expr (syn: Syntax): Elab.TermElabM (Except String Expr) := do
return .ok expr return .ok expr
catch ex => return .error (← ex.toMessageData.toString) catch ex => return .error (← ex.toMessageData.toString)
structure BoundExpression where
binders: Array (String × String) --- Output Functions ---
target: String
deriving ToJson def type_expr_to_bound (expr: Expr): MetaM Commands.BoundExpression := do
def type_expr_to_bound (expr: Expr): MetaM BoundExpression := do
Meta.forallTelescope expr fun arr body => do Meta.forallTelescope expr fun arr body => do
let binders ← arr.mapM fun fvar => do let binders ← arr.mapM fun fvar => do
return (toString (← fvar.fvarId!.getUserName), toString (← Meta.ppExpr (← fvar.fvarId!.getType))) return (toString (← fvar.fvarId!.getUserName), toString (← Meta.ppExpr (← fvar.fvarId!.getType)))
return { binders, target := toString (← Meta.ppExpr body) } return { binders, target := toString (← Meta.ppExpr body) }
structure Variable where
name: String
/-- Does the name contain a dagger -/
isInaccessible: Bool := false
type: String
value?: Option String := .none
deriving ToJson
structure Goal where
/-- String case id -/
caseName?: Option String := .none
/-- Is the goal in conversion mode -/
isConversion: Bool := false
/-- target expression type -/
target: String
/-- Variables -/
vars: Array Variable := #[]
deriving ToJson
/-- Adapted from ppGoal -/
def serialize_goal (mvarDecl: MetavarDecl) : MetaM Goal := do
-- Options for printing; See Meta.ppGoal for details
let showLetValues := True
let ppAuxDecls := false
let ppImplDetailHyps := false
let lctx := mvarDecl.lctx
let lctx := lctx.sanitizeNames.run' { options := (← getOptions) }
Meta.withLCtx lctx mvarDecl.localInstances do
let rec ppVars (localDecl : LocalDecl) : MetaM Variable := do
match localDecl with
| .cdecl _ _ varName type _ _ =>
let varName := varName.simpMacroScopes
let type ← instantiateMVars type
return {
name := toString varName,
isInaccessible := varName.isInaccessibleUserName,
type := toString <| ← Meta.ppExpr type
}
| .ldecl _ _ varName type val _ _ => do
let varName := varName.simpMacroScopes
let type ← instantiateMVars type
let value? ← if showLetValues then
let val ← instantiateMVars val
pure $ .some <| toString <| (← Meta.ppExpr val)
else
pure $ .none
return {
name := toString varName,
isInaccessible := varName.isInaccessibleUserName,
type := toString <| ← Meta.ppExpr 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 var ← ppVars localDecl
return var::acc
return {
caseName? := match mvarDecl.userName with
| Name.anonymous => .none
| name => .some <| toString name,
isConversion := "| " == (Meta.getGoalPrefix mvarDecl)
target := toString <| (← Meta.ppExpr (← instantiateMVars mvarDecl.type)),
vars := vars.reverse.toArray
}
/-- Completely serialises an expression tree. Json not used due to compactness -/ /-- Completely serialises an expression tree. Json not used due to compactness -/
def serialize_expression_ast (expr: Expr): MetaM String := do def serialize_expression_ast (expr: Expr): MetaM String := do
match expr with match expr with
@ -131,16 +67,16 @@ def serialize_expression_ast (expr: Expr): MetaM String := do
| .const declName _ => | .const declName _ =>
-- The universe level of the const expression is elided since it should be -- The universe level of the const expression is elided since it should be
-- inferrable from surrounding expression -- inferrable from surrounding expression
return s!"(:const {declName})" return s!"(:c {declName})"
| .app fn arg => | .app fn arg =>
let fn' ← serialize_expression_ast fn let fn' ← serialize_expression_ast fn
let arg' ← serialize_expression_ast arg let arg' ← serialize_expression_ast arg
return s!"(:app {fn'} {arg'})" return s!"({fn'} {arg'})"
| .lam binderName binderType body binderInfo => | .lam binderName binderType body binderInfo =>
let binderType' ← serialize_expression_ast binderType let binderType' ← serialize_expression_ast binderType
let body' ← serialize_expression_ast body let body' ← serialize_expression_ast body
let binderInfo' := binderInfoToAst binderInfo let binderInfo' := binderInfoToAst binderInfo
return s!"(:lam {binderName} {binderType'} {body'} :{binderInfo'})" return s!"(:lambda {binderName} {binderType'} {body'} :{binderInfo'})"
| .forallE binderName binderType body binderInfo => | .forallE binderName binderType body binderInfo =>
let binderType' ← serialize_expression_ast binderType let binderType' ← serialize_expression_ast binderType
let body' ← serialize_expression_ast body let body' ← serialize_expression_ast body
@ -170,11 +106,69 @@ def serialize_expression_ast (expr: Expr): MetaM String := do
| .strictImplicit => "strictImplicit" | .strictImplicit => "strictImplicit"
| .instImplicit => "instImplicit" | .instImplicit => "instImplicit"
/-- Serialised expression object --/ def serialize_expression (options: Commands.Options) (e: Expr): MetaM Commands.Expression := do
structure Expression where let pp := toString (← Meta.ppExpr e)
prettyprinted?: Option String := .none let pp?: Option String := match options.printExprPretty with
bound?: Option BoundExpression := .none | true => .some pp
sexp?: Option String := .none | false => .none
deriving ToJson let sexp: String := (← serialize_expression_ast e)
let sexp?: Option String := match options.printExprAST with
| true => .some sexp
| false => .none
return {
pp?,
sexp?
}
/-- Adapted from ppGoal -/
def serialize_goal (options: Commands.Options) (mvarDecl: MetavarDecl) : MetaM Commands.Goal := do
-- Options for printing; See Meta.ppGoal for details
let showLetValues := True
let ppAuxDecls := false
let ppImplDetailHyps := false
let lctx := mvarDecl.lctx
let lctx := lctx.sanitizeNames.run' { options := (← getOptions) }
Meta.withLCtx lctx mvarDecl.localInstances do
let rec ppVars (localDecl : LocalDecl) : MetaM Commands.Variable := do
match localDecl with
| .cdecl _ _ varName type _ _ =>
let varName := varName.simpMacroScopes
let type ← instantiateMVars type
return {
name := toString varName,
isInaccessible := varName.isInaccessibleUserName,
type := (← serialize_expression options type)
}
| .ldecl _ _ varName type val _ _ => do
let varName := varName.simpMacroScopes
let type ← instantiateMVars type
let value? ← if showLetValues then
let val ← instantiateMVars val
pure $ .some (← serialize_expression options val)
else
pure $ .none
return {
name := toString varName,
isInaccessible := varName.isInaccessibleUserName,
type := (← serialize_expression 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 var ← ppVars localDecl
return var::acc
return {
caseName? := match mvarDecl.userName with
| Name.anonymous => .none
| name => .some <| toString name,
isConversion := "| " == (Meta.getGoalPrefix mvarDecl)
target := (← serialize_expression options (← instantiateMVars mvarDecl.type)),
vars := vars.reverse.toArray
}
end Pantograph end Pantograph

View File

@ -33,7 +33,7 @@ result of a command execution. The command can be passed in one of two formats
command { ... } command { ... }
{ "cmd": command, "payload": ... } { "cmd": command, "payload": ... }
``` ```
The list of available commands can be found in `Pantograph/Commands.lean`. An The list of available commands can be found in `Pantograph/Commands.lean` and below. An
empty command aborts the REPL. empty command aborts the REPL.
The `Pantograph` executable must be run with a list of modules to import. It can The `Pantograph` executable must be run with a list of modules to import. It can
@ -65,8 +65,13 @@ where the application of `assumption` should lead to a failure.
## Commands ## Commands
See `Pantograph/Commands.lean` for a description of the parameters and return values in Json. See `Pantograph/Commands.lean` for a description of the parameters and return values in Json.
- `options.set { key: value, ... }`: Set one or more options (not Lean options; those
have to be set via command line arguments.)
- `options.print`: Display the current set of options
- `catalog`: Display a list of all safe Lean symbols in the current context - `catalog`: Display a list of all safe Lean symbols in the current context
- `inspect {"name": <name>}`: Show the type and package of a given symbol - `inspect {"name": <name>, "value": <bool>}`: Show the type and package of a
given symbol; If value flag is set, the value is printed or hidden. By default
only the values of definitions are printed.
- `clear`: Delete all cached expressions and proof trees - `clear`: Delete all cached expressions and proof trees
- `expr.type {"expr": <expr>}`: Determine the type of an expression and round-trip it - `expr.type {"expr": <expr>}`: Determine the type of an expression and round-trip it
- `proof.start {["name": <name>], ["expr": <expr>], ["copyFrom": <symbol>]}`: Start a new proof state from a given expression or symbol - `proof.start {["name": <name>], ["expr": <expr>], ["copyFrom": <symbol>]}`: Start a new proof state from a given expression or symbol
@ -86,4 +91,3 @@ The tests are based on `LSpec`. To run tests,
``` sh ``` sh
test/all.sh test/all.sh
``` ```

View File

@ -9,6 +9,7 @@ unsafe def main := do
Lean.enableInitializersExecution Lean.enableInitializersExecution
Lean.initSearchPath (← Lean.findSysroot) Lean.initSearchPath (← Lean.findSysroot)
-- TODO: Add proper testing
let suites := [ let suites := [
test_serial, test_serial,
test_proofs test_proofs