diff --git a/.gitignore b/.gitignore index 069f8e2..53ec3bb 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,4 @@ .* !.gitignore - -/build -/lake-packages +*.[io]lean +/result diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..34f63a3 --- /dev/null +++ b/LICENSE @@ -0,0 +1,190 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + Copyright 2024 Leni Aniva + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/Main.lean b/Main.lean index c08014d..be01ff6 100644 --- a/Main.lean +++ b/Main.lean @@ -1,28 +1,15 @@ import Lean.Data.Json import Lean.Environment -import Pantograph.Commands -import Pantograph.Serial -import Pantograph.Meta -import Pantograph.Symbols +import Pantograph +import Repl -namespace Pantograph - - -structure Context where - -/-- Stores state of the REPL -/ -structure State where - --environments: Array Lean.Environment := #[] - proofTrees: Array ProofTree := #[] - --- State monad -abbrev Subroutine := ReaderT Context (StateT State Lean.Elab.TermElabM) - -open Commands +-- Main IO functions +open Pantograph.Repl +open Pantograph.Protocol /-- Parse a command either in `{ "cmd": ..., "payload": ... }` form or `cmd { ... }` form. -/ -def parse_command (s: String): Except String Command := do +def parseCommand (s: String): Except String Command := do let s := s.trim match s.get? 0 with | .some '{' => -- Parse in Json mode @@ -36,209 +23,50 @@ def parse_command (s: String): Except String Command := do return { cmd := s.take offset, payload := payload } | .none => throw "Command is empty" -def execute (command: Command): Subroutine Lean.Json := do - match command.cmd with - | "catalog" => - match Lean.fromJson? command.payload with - | .ok args => catalog args - | .error x => return errorJson x - | "inspect" => - match Lean.fromJson? command.payload with - | .ok args => inspect args - | .error x => return errorJson x - | "clear" => clear - | "expr.type" => - match Lean.fromJson? command.payload with - | .ok args => expr_type args - | .error x => return errorJson x - | "proof.start" => - match Lean.fromJson? command.payload with - | .ok args => proof_start args - | .error x => return errorJson x - | "proof.tactic" => - match Lean.fromJson? command.payload with - | .ok args => proof_tactic args - | .error x => return errorJson x - | "proof.printTree" => - match Lean.fromJson? command.payload with - | .ok args => proof_print_tree args - | .error x => return errorJson x - | cmd => - let error: InteractionError := { error := "unknown", desc := s!"Unknown command {cmd}" } - return Lean.toJson error - where - errorI (type desc: String) := Lean.toJson ({ error := type, desc := desc }: InteractionError) - errorJson := errorI "json" - errorIndex := errorI "index" - catalog (_: Catalog): Subroutine Lean.Json := do - let env ← Lean.MonadEnv.getEnv - let names := env.constants.fold (init := #[]) (λ acc name info => - match to_filtered_symbol name info with - | .some x => acc.push x - | .none => acc) - return Lean.toJson <| ({ symbols := names }: CatalogResult) - inspect (args: Inspect): Subroutine Lean.Json := do - let env ← Lean.MonadEnv.getEnv - let name := str_to_name args.name - let info? := env.find? name - match info? with - | none => return errorIndex s!"Symbol not found {args.name}" - | some info => - let format ← Lean.Meta.ppExpr info.toConstantVal.type - let module? := env.getModuleIdxFor? name >>= - (λ idx => env.allImportedModuleNames.get? idx.toNat) |>.map toString - let boundExpr? ← (match info.toConstantVal.type with - | .forallE _ _ _ _ => return .some (← type_expr_to_bound info.toConstantVal.type) - | _ => return Option.none) - return Lean.toJson ({ - type := toString format, - boundExpr? := boundExpr?, - module? := module? - }: InspectResult) - clear : Subroutine Lean.Json := do - let state ← get - let nTrees := state.proofTrees.size - set { state with proofTrees := #[] } - return Lean.toJson ({ nTrees := nTrees }: ClearResult) - expr_type (args: ExprType): Subroutine Lean.Json := do - let env ← Lean.MonadEnv.getEnv - match syntax_from_str env args.expr with - | .error str => return errorI "parsing" str - | .ok syn => do - match (← syntax_to_expr syn) with - | .error str => return errorI "elab" str - | .ok expr => do - try - let format ← Lean.Meta.ppExpr (← Lean.Meta.inferType expr) - return Lean.toJson <| ({ - type := toString format, - roundTrip := toString <| (← Lean.Meta.ppExpr expr) - }: ExprTypeResult) - catch exception => - return errorI "typing" (← exception.toMessageData.toString) - proof_start (args: ProofStart): Subroutine Lean.Json := do - let state ← get - let env ← Lean.MonadEnv.getEnv - let expr?: Except Lean.Json Lean.Expr ← (match args.expr, args.copyFrom with - | .some expr, .none => - (match syntax_from_str env expr with - | .error str => return .error <| errorI "parsing" str - | .ok syn => do - (match (← syntax_to_expr syn) with - | .error str => return .error <| errorI "elab" str - | .ok expr => return .ok expr)) - | .none, .some copyFrom => - (match env.find? <| str_to_name copyFrom with - | .none => return .error <| errorIndex s!"Symbol not found: {copyFrom}" - | .some cInfo => return .ok cInfo.type) - | .none, .none => - return .error <| errorI "arguments" "At least one of {expr, copyFrom} must be supplied" - | _, _ => return .error <| errorI "arguments" "Cannot populate both of {expr, copyFrom}") - match expr? with - | .error error => return error - | .ok expr => - let tree ← ProofTree.create (str_to_name <| args.name.getD "Untitled") expr - -- Put the new tree in the environment - let nextTreeId := state.proofTrees.size - set { state with proofTrees := state.proofTrees.push tree } - return Lean.toJson ({ treeId := nextTreeId }: ProofStartResult) - proof_tactic (args: ProofTactic): Subroutine Lean.Json := do - let state ← get - match state.proofTrees.get? args.treeId with - | .none => return errorIndex "Invalid tree index {args.treeId}" - | .some tree => - let (result, nextTree) ← ProofTree.execute - (stateId := args.stateId) - (goalId := args.goalId.getD 0) - (tactic := args.tactic) |>.run tree - match result with - | .invalid message => return Lean.toJson <| errorIndex message - | .success nextId? goals => - set { state with proofTrees := state.proofTrees.set! args.treeId nextTree } - return Lean.toJson ({ nextId? := nextId?, goals := goals }: ProofTacticResultSuccess) - | .failure messages => - return Lean.toJson ({ tacticErrors := messages }: ProofTacticResultFailure) - proof_print_tree (args: ProofPrintTree): Subroutine Lean.Json := do - let state ← get - match state.proofTrees.get? args.treeId with - | .none => return errorIndex "Invalid tree index {args.treeId}" - | .some tree => - return Lean.toJson ({parents := tree.structure_array}: ProofPrintTreeResult) - - -end Pantograph - - --- Main IO functions -open Pantograph - -unsafe def loop : Subroutine Unit := do +partial def loop : MainM Unit := do + let state ← get let command ← (← IO.getStdin).getLine if command.trim.length = 0 then return () - match parse_command command with + match parseCommand command with | .error error => - let error := Lean.toJson ({ error := "json", desc := error }: Commands.InteractionError) - IO.println (toString error) + let error := Lean.toJson ({ error := "command", desc := error }: InteractionError) + -- Using `Lean.Json.compress` here to prevent newline + IO.println error.compress | .ok command => - let ret ← execute command - IO.println <| toString <| ret + try + let ret ← execute command + let str := match state.options.printJsonPretty with + | true => ret.pretty + | false => ret.compress + IO.println str + catch e => + let message ← e.toMessageData.toString + let error := Lean.toJson ({ error := "main", desc := message }: InteractionError) + IO.println error.compress loop -namespace Lean --- This is better than the default version since it handles `.` -def setOptionFromString' (opts : Options) (entry : String) : IO Options := do - let ps := (entry.splitOn "=").map String.trim - let [key, val] ← pure ps | throw $ IO.userError "invalid configuration option entry, it must be of the form ' = '" - let key := 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 $ IO.userError s!"invalid Bool option value '{val}'" - | DataValue.ofName _ => pure $ opts.setName key val.toName - | DataValue.ofNat _ => - match val.toNat? with - | none => throw (IO.userError s!"invalid Nat option value '{val}'") - | some v => pure $ opts.setNat key v - | DataValue.ofInt _ => - match val.toInt? with - | none => throw (IO.userError s!"invalid Int option value '{val}'") - | some v => pure $ opts.setInt key v - | DataValue.ofSyntax _ => throw (IO.userError s!"invalid Syntax option value") -end Lean unsafe def main (args: List String): IO Unit := do - Lean.enableInitializersExecution - Lean.initSearchPath (← Lean.findSysroot) - + -- NOTE: A more sophisticated scheme of command line argument handling is needed. -- Separate imports and options - let options := args.filterMap (λ s => if s.startsWith "--" then .some <| s.drop 2 else .none) - let imports:= args.filter (λ s => ¬ (s.startsWith "--")) + if args == ["--version"] then do + IO.println s!"{Pantograph.version}" + return - let env ← Lean.importModules - (imports := imports.map (λ str => { module := str_to_name str, runtimeOnly := false })) - (opts := {}) - (trustLevel := 1) + Pantograph.initSearch "" + + let coreContext ← args.filterMap (λ s => if s.startsWith "--" then .some <| s.drop 2 else .none) + |>.toArray |> Pantograph.createCoreContext + let imports:= args.filter (λ s => ¬ (s.startsWith "--")) + let coreState ← Pantograph.createCoreState imports.toArray let context: Context := { - } - let coreContext: Lean.Core.Context := { - currNamespace := str_to_name "Aniva", - openDecls := [], -- No 'open' directives needed - fileName := "", - fileMap := { source := "", positions := #[0], lines := #[1] }, - options := ← options.foldlM Lean.setOptionFromString' Lean.Options.empty + imports } try - let termElabM := loop.run context |>.run' {} - let metaM := termElabM.run' (ctx := { - declName? := some "_pantograph", - errToSorry := false - }) - let coreM := metaM.run' - discard <| coreM.toIO coreContext { env := env } + let coreM := loop.run context |>.run' {} + IO.println "ready." + discard <| coreM.toIO coreContext coreState catch ex => - IO.println "Uncaught IO exception" - IO.println ex.toString + let message := ex.toString + let error := Lean.toJson ({ error := "io", desc := message }: InteractionError) + IO.println error.compress diff --git a/Pantograph.lean b/Pantograph.lean index cd13b6f..2c334b6 100644 --- a/Pantograph.lean +++ b/Pantograph.lean @@ -1,2 +1,9 @@ -import Pantograph.Commands -import Pantograph.Symbols +import Pantograph.Delate +import Pantograph.Elab +import Pantograph.Environment +import Pantograph.Frontend +import Pantograph.Goal +import Pantograph.Library +import Pantograph.Protocol +import Pantograph.Serial +import Pantograph.Version diff --git a/Pantograph/Commands.lean b/Pantograph/Commands.lean deleted file mode 100644 index 4ad79b5..0000000 --- a/Pantograph/Commands.lean +++ /dev/null @@ -1,91 +0,0 @@ -/- -All the command input/output structures are stored here - -Note that no command other than `InteractionError` may have `error` as one of -its field names to avoid confusion with error messages generated by the REPL. --/ -import Lean.Data.Json - -import Pantograph.Serial - -namespace Pantograph.Commands - -structure Command where - cmd: String - payload: Lean.Json - deriving Lean.FromJson - -structure InteractionError where - error: String - desc: String - deriving Lean.ToJson - - --- Individual command and return types - - --- Print all symbols in environment -structure Catalog where - deriving Lean.FromJson -structure CatalogResult where - symbols: Array String - deriving Lean.ToJson - --- Print the type of a symbol -structure Inspect where - name: String - deriving Lean.FromJson -structure InspectResult where - type: String - -- Decompose the bound expression when the type is forall. - boundExpr?: Option BoundExpression - module?: Option String - deriving Lean.ToJson - -structure ClearResult where - nTrees: Nat - deriving Lean.ToJson - --- Get the type of an expression -structure ExprType where - expr: String - deriving Lean.FromJson -structure ExprTypeResult where - type: String - roundTrip: String - deriving Lean.ToJson - -structure ProofStart where - name: Option String -- Identifier of the proof - -- Only one of the fields below may be populated. - expr: Option String -- Proof expression - copyFrom: Option String -- Theorem name - deriving Lean.FromJson -structure ProofStartResult where - treeId: Nat := 0 -- Proof tree id - deriving Lean.ToJson - -structure ProofTactic where - -- Identifiers for tree, state, and goal - treeId: Nat - stateId: Nat - goalId: Option Nat - tactic: String - deriving Lean.FromJson -structure ProofTacticResultSuccess where - goals: Array Goal - nextId?: Option Nat -- Next proof state id - deriving Lean.ToJson -structure ProofTacticResultFailure where - tacticErrors: Array String -- Error messages generated by tactic - deriving Lean.ToJson - -structure ProofPrintTree where - treeId: Nat - deriving Lean.FromJson -structure ProofPrintTreeResult where - -- "" if no parents, otherwise "parentId.goalId" - parents: Array String - deriving Lean.ToJson - -end Pantograph.Commands diff --git a/Pantograph/Delate.lean b/Pantograph/Delate.lean new file mode 100644 index 0000000..4b3bd51 --- /dev/null +++ b/Pantograph/Delate.lean @@ -0,0 +1,561 @@ +/- +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 := fvarId.name + pure s!"(:fv {name})" + | .mvar mvarId => do + let pref := if ← mvarId.isDelayedAssigned then "mvd" else "mv" + let name := 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' := binderName.eraseMacroScopes + 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' := binderName.eraseMacroScopes + 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' := name.eraseMacroScopes + 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" + +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 := fvarId.name.toString, + userName:= ofName userName.simpMacroScopes, + isInaccessible := userName.isInaccessibleUserName + } + | .ldecl _ fvarId userName _ _ _ _ => do + return { + name := fvarId.name.toString, + 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 := fvarId.name.toString, + 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 := fvarId.name.toString, + 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 := goal.name.toString, + 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 diff --git a/Pantograph/Elab.lean b/Pantograph/Elab.lean new file mode 100644 index 0000000..3c3b3cd --- /dev/null +++ b/Pantograph/Elab.lean @@ -0,0 +1,40 @@ +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 := "") + +def parseTermM [Monad m] [MonadEnv m] (s: String): m (Except String Syntax) := do + return Parser.runParserCategory + (env := ← MonadEnv.getEnv) + (catName := `term) + (input := s) + (fileName := "") + +/-- 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 diff --git a/Pantograph/Environment.lean b/Pantograph/Environment.lean new file mode 100644 index 0000000..ad21284 --- /dev/null +++ b/Pantograph/Environment.lean @@ -0,0 +1,156 @@ +import Pantograph.Delate +import Pantograph.Elab +import Pantograph.Protocol +import Pantograph.Serial +import Lean.Environment +import Lean.Replay + +open Lean +open Pantograph + +namespace Pantograph.Environment + +@[export pantograph_is_name_internal] +def isNameInternal (n: Name): Bool := + -- Returns true if the name is an implementation detail which should not be shown to the user. + n.isAuxLemma ∨ n.hasMacroScopes + +/-- Catalog all the non-internal and safe names -/ +@[export pantograph_environment_catalog] +def env_catalog (env: Environment): Array Name := env.constants.fold (init := #[]) (λ acc name _ => + match isNameInternal name with + | false => acc.push name + | true => acc) + +@[export pantograph_environment_module_of_name] +def module_of_name (env: Environment) (name: Name): Option Name := do + let moduleId ← env.getModuleIdxFor? name + return env.allImportedModuleNames.get! moduleId.toNat + +def toCompactSymbolName (n: Name) (info: ConstantInfo): String := + let pref := match info with + | .axiomInfo _ => "a" + | .defnInfo _ => "d" + | .thmInfo _ => "t" + | .opaqueInfo _ => "o" + | .quotInfo _ => "q" + | .inductInfo _ => "i" + | .ctorInfo _ => "c" + | .recInfo _ => "r" + s!"{pref}{toString n}" + +def toFilteredSymbol (n: Lean.Name) (info: Lean.ConstantInfo): Option String := + if isNameInternal n || info.isUnsafe + then Option.none + else Option.some <| toCompactSymbolName n info +def catalog (_: Protocol.EnvCatalog): CoreM Protocol.EnvCatalogResult := do + let env ← Lean.MonadEnv.getEnv + let names := env.constants.fold (init := #[]) (λ acc name info => + match toFilteredSymbol name info with + | .some x => acc.push x + | .none => acc) + return { symbols := names } +def inspect (args: Protocol.EnvInspect) (options: @&Protocol.Options): CoreM (Protocol.CR Protocol.EnvInspectResult) := do + let env ← Lean.MonadEnv.getEnv + let name := args.name.toName + let info? := env.find? name + let info ← match info? with + | none => return .error $ Protocol.errorIndex s!"Symbol not found {args.name}" + | some info => pure info + let module? := env.getModuleIdxFor? name >>= + (λ idx => env.allImportedModuleNames.get? idx.toNat) |>.map toString + let value? := match args.value?, info with + | .some true, _ => info.value? + | .some false, _ => .none + | .none, .defnInfo _ => info.value? + | .none, _ => .none + let type ← unfoldAuxLemmas info.type + let value? ← value?.mapM (λ v => unfoldAuxLemmas v) + -- Information common to all symbols + let core := { + type := ← (serializeExpression options type).run', + isUnsafe := info.isUnsafe, + value? := ← value?.mapM (λ v => serializeExpression options v |>.run'), + publicName? := Lean.privateToUserName? name |>.map (·.toString), + -- BUG: Warning: getUsedConstants here will not include projections. This is a known bug. + typeDependency? := if args.dependency?.getD false + then .some <| type.getUsedConstants.map (λ n => serializeName n) + else .none, + valueDependency? := if args.dependency?.getD false + then value?.map (λ e => + e.getUsedConstants.filter (!isNameInternal ·) |>.map (λ n => serializeName n) ) + else .none, + module? := module? + } + let result ← match info with + | .inductInfo induct => pure { core with inductInfo? := .some { + numParams := induct.numParams, + numIndices := induct.numIndices, + all := induct.all.toArray.map (·.toString), + ctors := induct.ctors.toArray.map (·.toString), + isRec := induct.isRec, + isReflexive := induct.isReflexive, + isNested := induct.isNested, + } } + | .ctorInfo ctor => pure { core with constructorInfo? := .some { + induct := ctor.induct.toString, + cidx := ctor.cidx, + numParams := ctor.numParams, + numFields := ctor.numFields, + } } + | .recInfo r => pure { core with recursorInfo? := .some { + all := r.all.toArray.map (·.toString), + numParams := r.numParams, + numIndices := r.numIndices, + numMotives := r.numMotives, + numMinors := r.numMinors, + rules := ← r.rules.toArray.mapM (λ rule => do + pure { + ctor := rule.ctor.toString, + nFields := rule.nfields, + rhs := ← (serializeExpression options rule.rhs).run', + }) + k := r.k, + } } + | _ => pure core + return .ok result +def addDecl (args: Protocol.EnvAdd): CoreM (Protocol.CR Protocol.EnvAddResult) := do + let env ← Lean.MonadEnv.getEnv + let tvM: Elab.TermElabM (Except String (Expr × Expr)) := do + let type ← match parseTerm env args.type with + | .ok syn => do + match ← elabTerm syn with + | .error e => return .error e + | .ok expr => pure expr + | .error e => return .error e + let value ← match parseTerm env args.value with + | .ok syn => do + try + let expr ← Elab.Term.elabTerm (stx := syn) (expectedType? := .some type) + Lean.Elab.Term.synthesizeSyntheticMVarsNoPostponing + let expr ← instantiateMVars expr + pure $ expr + catch ex => return .error (← ex.toMessageData.toString) + | .error e => return .error e + pure $ .ok (type, value) + let (type, value) ← match ← tvM.run' (ctx := {}) |>.run' with + | .ok t => pure t + | .error e => return .error $ Protocol.errorExpr e + let constant := Lean.Declaration.defnDecl <| Lean.mkDefinitionValEx + (name := args.name.toName) + (levelParams := []) + (type := type) + (value := value) + (hints := Lean.mkReducibilityHintsRegularEx 1) + (safety := Lean.DefinitionSafety.safe) + (all := []) + let env' ← match env.addDecl (← getOptions) constant with + | .error e => do + let options ← Lean.MonadOptions.getOptions + let desc ← (e.toMessageData options).toString + return .error $ { error := "kernel", desc } + | .ok env' => pure env' + Lean.MonadEnv.modifyEnv (λ _ => env') + return .ok {} + +end Pantograph.Environment diff --git a/Pantograph/Frontend.lean b/Pantograph/Frontend.lean new file mode 100644 index 0000000..9a41567 --- /dev/null +++ b/Pantograph/Frontend.lean @@ -0,0 +1,4 @@ +import Pantograph.Frontend.Basic +import Pantograph.Frontend.Elab +import Pantograph.Frontend.InfoTree +import Pantograph.Frontend.MetaTranslate diff --git a/Pantograph/Frontend/Basic.lean b/Pantograph/Frontend/Basic.lean new file mode 100644 index 0000000..87decd4 --- /dev/null +++ b/Pantograph/Frontend/Basic.lean @@ -0,0 +1,127 @@ +import Lean.Parser +import Lean.Elab.Frontend + +open Lean + +namespace Lean.FileMap + +/-- Extract the range of a `Syntax` expressed as lines and columns. -/ +-- Extracted from the private declaration `Lean.Elab.formatStxRange`, +-- in `Lean.Elab.InfoTree.Main`. +@[export pantograph_frontend_stx_range] +protected def stxRange (fileMap : FileMap) (stx : Syntax) : Position × Position := + let pos := stx.getPos?.getD 0 + let endPos := stx.getTailPos?.getD pos + (fileMap.toPosition pos, fileMap.toPosition endPos) + +end Lean.FileMap +namespace Lean.PersistentArray + +/-- +Drop the first `n` elements of a `PersistentArray`, returning the results as a `List`. +-/ +-- We can't remove the `[Inhabited α]` hypotheses here until +-- `PersistentArray`'s `GetElem` instance also does. +protected def drop [Inhabited α] (t : PersistentArray α) (n : Nat) : List α := + List.range (t.size - n) |>.map fun i => t.get! (n + i) + +end Lean.PersistentArray + + +namespace Pantograph.Frontend + +@[export pantograph_frontend_stx_byte_range] +def stxByteRange (stx : Syntax) : String.Pos × String.Pos := + let pos := stx.getPos?.getD 0 + let endPos := stx.getTailPos?.getD 0 + (pos, endPos) + + +abbrev FrontendM := Elab.Frontend.FrontendM + +structure CompilationStep where + fileName : String + fileMap : FileMap + src : Substring + stx : Syntax + before : Environment + after : Environment + msgs : List Message + trees : List Elab.InfoTree + +namespace CompilationStep + +@[export pantograph_frontend_compilation_step_message_strings_m] +def messageStrings (step: CompilationStep) : IO (Array String) := do + List.toArray <$> step.msgs.mapM (·.toString) + +end CompilationStep + + +/-- +Process one command, returning a `CompilationStep` and +`done : Bool`, indicating whether this was the last command. +-/ +@[export pantograph_frontend_process_one_command_m] +def processOneCommand: FrontendM (CompilationStep × Bool) := do + let s := (← get).commandState + let before := s.env + let done ← Elab.Frontend.processCommand + let stx := (← get).commands.back + let src := (← read).inputCtx.input.toSubstring.extract (← get).cmdPos (← get).parserState.pos + let s' := (← get).commandState + let after := s'.env + let msgs := s'.messages.toList.drop s.messages.toList.length + let trees := s'.infoState.trees.drop s.infoState.trees.size + let ⟨_, fileName, fileMap⟩ := (← read).inputCtx + return ({ fileName, fileMap, src, stx, before, after, msgs, trees }, done) + +partial def mapCompilationSteps { α } (f: CompilationStep → IO α) : FrontendM (List α) := do + let (cmd, done) ← processOneCommand + if done then + if cmd.src.isEmpty then + return [] + else + return [← f cmd] + else + return (← f cmd) :: (← mapCompilationSteps f) + + +@[export pantograph_frontend_find_source_path_m] +def findSourcePath (module : Name) : IO System.FilePath := do + return System.FilePath.mk ((← findOLean module).toString.replace ".lake/build/lib/" "") |>.withExtension "lean" + +/-- +Use with +```lean +let m: FrontendM α := ... +let (context, state) ← createContextStateFromFile ... +m.run context |>.run' state +``` +-/ +@[export pantograph_frontend_create_context_state_from_file_m] +def createContextStateFromFile + (file : String) -- Content of the file + (fileName : String := "") + (env? : Option Lean.Environment := .none) -- If set to true, assume there's no header. + (opts : Options := {}) + : IO (Elab.Frontend.Context × Elab.Frontend.State) := unsafe do + --let file ← IO.FS.readFile (← findSourcePath module) + let inputCtx := Parser.mkInputContext file fileName + + let (env, parserState, messages) ← match env? with + | .some env => pure (env, {}, .empty) + | .none => + let (header, parserState, messages) ← Parser.parseHeader inputCtx + let (env, messages) ← Elab.processHeader header opts messages inputCtx + pure (env, parserState, messages) + let commandState := Elab.Command.mkState env messages opts + let context: Elab.Frontend.Context := { inputCtx } + let state: Elab.Frontend.State := { + commandState := { commandState with infoState.enabled := true }, + parserState, + cmdPos := parserState.pos + } + return (context, state) + +end Pantograph.Frontend diff --git a/Pantograph/Frontend/Elab.lean b/Pantograph/Frontend/Elab.lean new file mode 100644 index 0000000..3da5fca --- /dev/null +++ b/Pantograph/Frontend/Elab.lean @@ -0,0 +1,182 @@ +import Lean.Elab.Import +import Lean.Elab.Command +import Lean.Elab.InfoTree +import Lean.DeclarationRange + +import Pantograph.Frontend.Basic +import Pantograph.Frontend.MetaTranslate +import Pantograph.Goal +import Pantograph.Protocol +import Pantograph.Frontend.InfoTree + +open Lean + +namespace Pantograph.Frontend + +-- Info tree filtering functions + +/- Adapted from lean-training-data -/ +structure TacticInvocation where + info : Elab.TacticInfo + ctx : Elab.ContextInfo + children : PersistentArray Elab.InfoTree +namespace TacticInvocation + +/-- Return the range of the tactic, as a pair of file positions. -/ +@[export pantograph_frontend_tactic_invocation_range] +protected def range (t : TacticInvocation) : Position × Position := t.ctx.fileMap.stxRange t.info.stx + +/-- Pretty print a tactic. -/ +protected def pp (t : TacticInvocation) : IO Format := + t.ctx.runMetaM {} try + Lean.PrettyPrinter.ppTactic ⟨t.info.stx⟩ + catch _ => + pure "" + +/-- Run a tactic on the goals stored in a `TacticInvocation`. -/ +protected def runMetaMGoalsBefore (t : TacticInvocation) (x : List MVarId → MetaM α) : IO α := do + t.ctx.runMetaM {} <| Meta.withMCtx t.info.mctxBefore <| x t.info.goalsBefore + +/-- Run a tactic on the after goals stored in a `TacticInvocation`. -/ +protected def runMetaMGoalsAfter (t : TacticInvocation) (x : List MVarId → MetaM α) : IO α := do + t.ctx.runMetaM {} <| Meta.withMCtx t.info.mctxAfter <| x t.info.goalsAfter + +/-- Run a tactic on the main goal stored in a `TacticInvocation`. -/ +protected def runMetaM (t : TacticInvocation) (x : MVarId → MetaM α) : IO α := do + match t.info.goalsBefore.head? with + | none => throw <| IO.userError s!"No goals at {← t.pp}" + | some g => t.runMetaMGoalsBefore fun _ => do g.withContext <| x g + +protected def goalState (t : TacticInvocation) : IO (List Format) := do + t.runMetaMGoalsBefore (fun gs => gs.mapM fun g => do Meta.ppGoal g) + +protected def goalStateAfter (t : TacticInvocation) : IO (List Format) := do + t.runMetaMGoalsAfter (fun gs => gs.mapM fun g => do Meta.ppGoal g) + +protected def ppExpr (t : TacticInvocation) (e : Expr) : IO Format := + 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 + +/-- Return all `TacticInfo` nodes in an `InfoTree` corresponding to tactics, +each equipped with its relevant `ContextInfo`, and any children info trees. -/ +private def collectTacticNodes (t : Elab.InfoTree) : List TacticInvocation := + let infos := t.findAllInfo none false fun i => match i with + | .ofTacticInfo _ => true + | _ => false + infos.filterMap fun p => match p with + | (.ofTacticInfo i, some ctx, children) => .some ⟨i, ctx, children⟩ + | _ => none + +def collectTactics (t : Elab.InfoTree) : List TacticInvocation := + collectTacticNodes t |>.filter fun i => i.info.isSubstantive + +@[export pantograph_frontend_collect_tactics_from_compilation_step_m] +def collectTacticsFromCompilationStep (step : CompilationStep) : IO (List Protocol.InvokedTactic) := do + let tacticInfoTrees := step.trees.bind λ tree => tree.filter λ + | info@(.ofTacticInfo _) => info.isOriginal + | _ => false + let tactics := tacticInfoTrees.bind collectTactics + tactics.mapM λ invocation => do + let goalBefore := (Format.joinSep (← invocation.goalState) "\n").pretty + let goalAfter := (Format.joinSep (← invocation.goalStateAfter) "\n").pretty + let tactic ← invocation.ctx.runMetaM {} <| Meta.withMCtx invocation.info.mctxBefore do + return (← invocation.ctx.ppSyntax {} invocation.info.stx).pretty + -- FIXME: Why does this not work? There are problems with `term.pseudo.antiquot` + --PrettyPrinter.ppTactic ⟨invocation.info.stx⟩ + --return t.pretty + let usedConstants := invocation.usedConstants.toArray.map λ n => n.toString + return { + goalBefore, + goalAfter, + tactic, + usedConstants, + } + +structure InfoWithContext where + info: Elab.Info + context?: Option Elab.ContextInfo := .none + +private def collectSorrysInTree (t : Elab.InfoTree) : IO (List InfoWithContext) := do + let infos ← t.findAllInfoM none fun i ctx? => match i with + | .ofTermInfo { expectedType?, expr, stx, lctx, .. } => do + let .some ctx := ctx? | return (false, true) + if expr.isSorry ∧ stx.isOfKind `Lean.Parser.Term.sorry then + if expectedType?.isNone then + throw $ .userError "Sorry of indeterminant type is not allowed" + return (true, false) + let .some expectedType := expectedType? | return (false, true) + let typeMatch ← ctx.runMetaM lctx do + let type ← Meta.inferType expr + Meta.isExprDefEqGuarded type expectedType + return match typeMatch, expr.hasSorry with + | false, true => (true, false) -- Types mismatch but has sorry -> collect, halt + | false, false => (true, false) -- Types mistmatch but no sorry -> collect, halt + | true, true => (false, true) -- Types match but has sorry -> continue + | true, false => (false, false) -- Types match but no sorries -> halt + | .ofTacticInfo { stx, goalsBefore, .. } => + -- The `sorry` term is distinct from the `sorry` tactic + let isSorry := stx.isOfKind `Lean.Parser.Tactic.tacticSorry + return (isSorry ∧ !goalsBefore.isEmpty, ¬ isSorry) + | _ => return (false, true) + return infos.map fun (info, context?, _) => { info, context? } + +-- NOTE: Plural deliberately not spelled "sorries" +@[export pantograph_frontend_collect_sorrys_m] +def collectSorrys (step: CompilationStep) : IO (List InfoWithContext) := do + return (← step.trees.mapM collectSorrysInTree).join + +structure AnnotatedGoalState where + state : GoalState + srcBoundaries : List (String.Pos × String.Pos) + +/-- +Since we cannot directly merge `MetavarContext`s, we have to get creative. This +function duplicates frozen mvars in term and tactic info nodes, and add them to +the current `MetavarContext`. +-/ +@[export pantograph_frontend_sorrys_to_goal_state_m] +def sorrysToGoalState (sorrys : List InfoWithContext) : MetaM AnnotatedGoalState := do + assert! !sorrys.isEmpty + let goalsM := sorrys.mapM λ i => do + match i.info with + | .ofTermInfo termInfo => do + let mvarId ← MetaTranslate.translateMVarFromTermInfo termInfo i.context? + return [(mvarId, stxByteRange termInfo.stx)] + | .ofTacticInfo tacticInfo => do + let mvarIds ← MetaTranslate.translateMVarFromTacticInfoBefore tacticInfo i.context? + let range := stxByteRange tacticInfo.stx + return mvarIds.map (·, range) + | _ => panic! "Invalid info" + let annotatedGoals := List.join (← goalsM.run {} |>.run' {}) + let goals := annotatedGoals.map Prod.fst + let srcBoundaries := annotatedGoals.map Prod.snd + let root := match goals with + | [] => panic! "No MVars generated" + | [g] => g + | _ => { name := .anonymous } + let state ← GoalState.createFromMVars goals root + return { state, srcBoundaries } + + +@[export pantograph_frontend_collect_new_defined_constants_m] +def collectNewDefinedConstants (step : CompilationStep) : IO (List Name) := do + step.after.constants.map₂.foldlM (λ acc name _ => do + if step.before.contains name then + return acc + let coreM : CoreM Bool := Option.isSome <$> findDeclarationRanges? name + let hasRange ← coreM.run' { fileName := step.fileName, fileMap := step.fileMap } { env := step.after } |>.toBaseIO + match hasRange with + | .ok true => return name :: acc + | .ok false => return acc + | .error e => throw $ IO.userError (← e.toMessageData.toString) + ) [] + +end Pantograph.Frontend diff --git a/Pantograph/Frontend/InfoTree.lean b/Pantograph/Frontend/InfoTree.lean new file mode 100644 index 0000000..cfef621 --- /dev/null +++ b/Pantograph/Frontend/InfoTree.lean @@ -0,0 +1,153 @@ +/- Adapted from lean-training-data -/ +import Lean.Elab.InfoTree +import Lean.Parser.Term +import Lean.PrettyPrinter + +open Lean + +namespace Lean.Elab + +private def elaboratorToString : Name → String + | .anonymous => "" + | n => s!"⟨{n}⟩ " +private def indent (s : String) : String := "\n".intercalate $ s.splitOn "\n" |>.map ("\t" ++ .) + +/-- The `Syntax` for a `Lean.Elab.Info`, if there is one. -/ +protected def Info.stx? : Info → Option Syntax + | .ofTacticInfo info => info.stx + | .ofTermInfo info => info.stx + | .ofCommandInfo info => info.stx + | .ofMacroExpansionInfo info => info.stx + | .ofOptionInfo info => info.stx + | .ofFieldInfo info => info.stx + | .ofCompletionInfo info => info.stx + | .ofUserWidgetInfo info => info.stx + | .ofCustomInfo info => info.stx + | .ofFVarAliasInfo _ => none + | .ofFieldRedeclInfo info => info.stx + | .ofOmissionInfo info => info.stx +/-- Is the `Syntax` for this `Lean.Elab.Info` original, or synthetic? -/ +protected def Info.isOriginal (i : Info) : Bool := + match i.stx? with + | none => true -- Somewhat unclear what to do with `FVarAliasInfo`, so be conservative. + | some stx => match stx.getHeadInfo with + | .original .. => true + | _ => false + +def ContextInfo.ppExpr (ctx : ContextInfo) (lctx : LocalContext) (e : Expr) : IO Format := + ctx.runMetaM lctx (do Meta.ppExpr (← instantiateMVars e)) + +def CommandInfo.toString (info : CommandInfo) (ctx : ContextInfo) : IO String := do + let stx := (← ctx.ppSyntax {} info.stx).pretty + return s!"{elaboratorToString info.elaborator}\n{stx}" + +def TermInfo.toString (info : TermInfo) (ctx : ContextInfo) : IO String := do + let stx := (← ctx.ppSyntax info.lctx info.stx).pretty + let expectedType := (← info.expectedType?.mapM fun ty => do + pure s!": {(← ctx.ppExpr info.lctx ty).pretty}").getD "" + let expr := (← ctx.ppExpr info.lctx info.expr).pretty + return s!"{elaboratorToString info.elaborator}{expr}{expectedType}\n{stx}" + +/-- Find the name for the outermost `Syntax` in this `TacticInfo`. -/ +def TacticInfo.name? (t : TacticInfo) : Option Name := + match t.stx with + | Syntax.node _ n _ => some n + | _ => none +/-- Decide whether a tactic is "substantive", +or is merely a tactic combinator (e.g. `by`, `;`, multiline tactics, parenthesized tactics). -/ +def TacticInfo.isSubstantive (t : TacticInfo) : Bool := + match t.name? with + | none => false + | some `null => false + | some ``cdot => false + | some ``cdotTk => false + | some ``Lean.Parser.Term.byTactic => false + | some ``Lean.Parser.Tactic.tacticSeq => false + | some ``Lean.Parser.Tactic.tacticSeq1Indented => false + | some ``Lean.Parser.Tactic.«tactic_<;>_» => false + | some ``Lean.Parser.Tactic.paren => false + | _ => true +def TacticInfo.pp (info : TacticInfo) (ctx : ContextInfo) : IO Format := + ctx.runMetaM {} try + Lean.PrettyPrinter.ppTactic ⟨info.stx⟩ + catch _ => + pure "" +def TacticInfo.toString (i : TacticInfo) (ctx : ContextInfo) : IO String := do + let name := i.name? + let stx := Format.pretty (← i.pp ctx) + return s!"{name}\n{stx}" + +/-- +Keep `.node` nodes and `.hole` nodes satisfying predicates. + +Returns a `List InfoTree`, although in most situations this will be a singleton. +-/ +partial def InfoTree.filter (p : Info → Bool) (m : MVarId → Bool := fun _ => false) : + InfoTree → List InfoTree + | .context ctx tree => tree.filter p m |>.map (.context ctx) + | .node info children => + if p info then + [.node info (children.toList.map (filter p m)).join.toPArray'] + else + (children.toList.map (filter p m)).join + | .hole mvar => if m mvar then [.hole mvar] else [] + +/-- Analogue of `Lean.Elab.InfoTree.findInfo?`, but that returns a list of all results. -/ +partial def InfoTree.findAllInfo + (t : InfoTree) + (context?: Option Elab.ContextInfo) + (haltOnMatch : Bool := false) + (pred : Elab.Info → Bool) + : List (Elab.Info × Option Elab.ContextInfo × PersistentArray Elab.InfoTree) := + match t with + | .context inner t => findAllInfo t (inner.mergeIntoOuter? context?) haltOnMatch pred + | .node i children => + let head := if pred i then [(i, context?, children)] else [] + let tail := if haltOnMatch ∧ !head.isEmpty then [] else children.toList.bind (fun t => findAllInfo t context? haltOnMatch pred) + head ++ tail + | _ => [] + +/-- Monadic analogue of `findAllInfo`, but predicate controls whether to recurse. -/ +partial def InfoTree.findAllInfoM [Monad m] + (t : InfoTree) + (context?: Option Elab.ContextInfo) + (pred : Elab.Info → Option Elab.ContextInfo → m (Bool × Bool)) + : m (List (Elab.Info × Option Elab.ContextInfo × PersistentArray Elab.InfoTree)) := do + match t with + | .context inner t => t.findAllInfoM (inner.mergeIntoOuter? context?) pred + | .node i children => + let (flagCollect, flagRecurse) ← pred i context? + let head := if flagCollect then [(i, context?, children)] else [] + let tail := if ¬ flagRecurse then pure [] else children.toList.mapM (fun t => t.findAllInfoM context? pred) + return head ++ (← tail).join + | _ => return [] + +@[export pantograph_infotree_to_string_m] +partial def InfoTree.toString (t : InfoTree) (ctx?: Option Elab.ContextInfo := .none) : IO String := do + match t with + | .context ctx t => t.toString (ctx.mergeIntoOuter? ctx?) + | .node info children => + if let some ctx := ctx? then + let node : String ← match info with + | .ofTermInfo info => pure s!"[term] {(← info.toString ctx)}" + | .ofCommandInfo info => pure s!"[command] {(← info.toString ctx)}" + | .ofTacticInfo info => pure s!"[tactic] {(← info.toString ctx)}" + | .ofMacroExpansionInfo _ => pure "[macro_exp]" + | .ofOptionInfo _ => pure "[option]" + | .ofFieldInfo _ => pure "[field]" + | .ofCompletionInfo _ => pure "[completion]" + | .ofUserWidgetInfo _ => pure "[user_widget]" + | .ofCustomInfo _ => pure "[custom]" + | .ofFVarAliasInfo _ => pure "[fvar]" + | .ofFieldRedeclInfo _ => pure "[field_redecl]" + | .ofOmissionInfo _ => pure "[omission]" + let children := "\n".intercalate (← children.toList.mapM λ t' => do pure $ indent $ ← t'.toString ctx) + return s!"{node}\n{children}" + else throw <| IO.userError "No `ContextInfo` available." + | .hole mvarId => + if let some ctx := ctx? then + let payload := (← ctx.runMetaM {} (do Meta.ppGoal mvarId)).pretty + return s!"[hole] {payload}" + else throw <| IO.userError "No `ContextInfo` available." + +end Lean.Elab diff --git a/Pantograph/Frontend/MetaTranslate.lean b/Pantograph/Frontend/MetaTranslate.lean new file mode 100644 index 0000000..bd3568d --- /dev/null +++ b/Pantograph/Frontend/MetaTranslate.lean @@ -0,0 +1,164 @@ +import Lean.Meta +import Std.Data.HashMap + +open Lean + +namespace Pantograph.Frontend + +namespace MetaTranslate + +structure Context where + sourceMCtx : MetavarContext := {} + sourceLCtx : LocalContext := {} + +abbrev FVarMap := Std.HashMap FVarId FVarId + +structure State where + -- Stores mapping from old to new mvar/fvars + mvarMap: Std.HashMap MVarId MVarId := {} + fvarMap: Std.HashMap FVarId FVarId := {} + +/- +Monadic state for translating a frozen meta state. The underlying `MetaM` +operates in the "target" context and state. +-/ +abbrev MetaTranslateM := ReaderT Context StateRefT State MetaM + +def getSourceLCtx : MetaTranslateM LocalContext := do pure (← read).sourceLCtx +def getSourceMCtx : MetaTranslateM MetavarContext := do pure (← read).sourceMCtx +def addTranslatedFVar (src dst: FVarId) : MetaTranslateM Unit := do + modifyGet λ state => ((), { state with fvarMap := state.fvarMap.insert src dst }) +def addTranslatedMVar (src dst: MVarId) : MetaTranslateM Unit := do + modifyGet λ state => ((), { state with mvarMap := state.mvarMap.insert src dst }) + +def saveFVarMap : MetaTranslateM FVarMap := do + return (← get).fvarMap +def restoreFVarMap (map: FVarMap) : MetaTranslateM Unit := do + modifyGet λ state => ((), { state with fvarMap := map }) +def resetFVarMap : MetaTranslateM Unit := do + modifyGet λ state => ((), { state with fvarMap := {} }) + +mutual +private partial def translateLevel (srcLevel: Level) : MetaTranslateM Level := do + let sourceMCtx ← getSourceMCtx + let (_, level) := instantiateLevelMVarsImp sourceMCtx srcLevel + match level with + | .zero => return .zero + | .succ inner => do + let inner' ← translateLevel inner + return .succ inner' + | .max l1 l2 => do + let l1' ← translateLevel l1 + let l2' ← translateLevel l2 + return .max l1' l2' + | .imax l1 l2 => do + let l1' ← translateLevel l1 + let l2' ← translateLevel l2 + return .imax l1' l2' + | .param p => return .param p + | .mvar _ => + Meta.mkFreshLevelMVar +private partial def translateExpr (srcExpr: Expr) : MetaTranslateM Expr := do + let sourceMCtx ← getSourceMCtx + -- We want to create as few mvars as possible + let (srcExpr, _) := instantiateMVarsCore (mctx := sourceMCtx) srcExpr + --IO.println s!"Transform src: {srcExpr}" + let result ← Core.transform srcExpr λ e => do + let state ← get + match e with + | .fvar fvarId => + let .some fvarId' := state.fvarMap[fvarId]? | panic! s!"FVar id not registered: {fvarId.name}" + assert! (← getLCtx).contains fvarId' + return .done $ .fvar fvarId' + | .mvar mvarId => do + -- Must not be assigned + assert! !(sourceMCtx.eAssignment.contains mvarId) + match state.mvarMap[mvarId]? with + | .some mvarId' => do + return .done $ .mvar mvarId' + | .none => do + -- Entering another LCtx, must save the current one + let fvarMap ← saveFVarMap + let mvarId' ← translateMVarId mvarId + restoreFVarMap fvarMap + return .done $ .mvar mvarId' + | .sort level => do + let level' ← translateLevel level + return .done $ .sort level' + | _ => return .continue + Meta.check result + return result + +partial def translateLocalInstance (srcInstance: LocalInstance) : MetaTranslateM LocalInstance := do + return { + className := srcInstance.className, + fvar := ← translateExpr srcInstance.fvar + } +partial def translateLocalDecl (srcLocalDecl: LocalDecl) : MetaTranslateM LocalDecl := do + let fvarId ← mkFreshFVarId + addTranslatedFVar srcLocalDecl.fvarId fvarId + match srcLocalDecl with + | .cdecl index _ userName type bi kind => do + --IO.println s!"[CD] {userName} {toString type}" + return .cdecl index fvarId userName (← translateExpr type) bi kind + | .ldecl index _ userName type value nonDep kind => do + --IO.println s!"[LD] {toString type} := {toString value}" + return .ldecl index fvarId userName (← translateExpr type) (← translateExpr value) nonDep kind + +partial def translateLCtx : MetaTranslateM LocalContext := do + resetFVarMap + let lctx ← MonadLCtx.getLCtx + assert! lctx.isEmpty + (← getSourceLCtx).foldlM (λ lctx srcLocalDecl => do + let localDecl ← Meta.withLCtx lctx #[] do + translateLocalDecl srcLocalDecl + pure $ lctx.addDecl localDecl + ) lctx + +partial def translateMVarId (srcMVarId: MVarId) : MetaTranslateM MVarId := do + if let .some mvarId' := (← get).mvarMap[srcMVarId]? then + return mvarId' + let mvarId' ← Meta.withLCtx .empty #[] do + let srcDecl := (← getSourceMCtx).findDecl? srcMVarId |>.get! + withTheReader Context (λ ctx => { ctx with sourceLCtx := srcDecl.lctx }) do + let lctx' ← translateLCtx + let localInstances' ← srcDecl.localInstances.mapM translateLocalInstance + Meta.withLCtx lctx' localInstances' do + let target' ← translateExpr srcDecl.type + let mvar' ← Meta.mkFreshExprMVar target' srcDecl.kind srcDecl.userName + let mvarId' := mvar'.mvarId! + if let .some { fvars, mvarIdPending }:= (← getSourceMCtx).getDelayedMVarAssignmentExp srcMVarId then + -- Map the fvars in the pending context. + let mvarIdPending' ← translateMVarId mvarIdPending + let fvars' ← mvarIdPending'.withContext $ fvars.mapM translateExpr + assignDelayedMVar mvarId' fvars' mvarIdPending' + pure mvarId' + addTranslatedMVar srcMVarId mvarId' + return mvarId' +end + +def translateMVarFromTermInfo (termInfo : Elab.TermInfo) (context? : Option Elab.ContextInfo) + : MetaTranslateM MVarId := do + withTheReader Context (λ ctx => { ctx with + sourceMCtx := context?.map (·.mctx) |>.getD {}, + sourceLCtx := termInfo.lctx, + }) do + let type := termInfo.expectedType?.get! + let lctx' ← translateLCtx + let mvar ← Meta.withLCtx lctx' #[] do + let type' ← translateExpr type + Meta.mkFreshExprSyntheticOpaqueMVar type' + return mvar.mvarId! + + +def translateMVarFromTacticInfoBefore (tacticInfo : Elab.TacticInfo) (_context? : Option Elab.ContextInfo) + : MetaTranslateM (List MVarId) := do + withTheReader Context (λ ctx => { ctx with sourceMCtx := tacticInfo.mctxBefore }) do + tacticInfo.goalsBefore.mapM translateMVarId + + +end MetaTranslate + +export MetaTranslate (MetaTranslateM) + +end Pantograph.Frontend diff --git a/Pantograph/Goal.lean b/Pantograph/Goal.lean new file mode 100644 index 0000000..6ff14d2 --- /dev/null +++ b/Pantograph/Goal.lean @@ -0,0 +1,444 @@ +/- +Functions for handling metavariables + +All the functions starting with `try` resume their inner monadic state. +-/ +import Pantograph.Tactic +import Lean + + +namespace Pantograph +open Lean + +/-- +Represents an interconnected set of metavariables, or a state in proof search + -/ +structure GoalState where + savedState : Elab.Tactic.SavedState + + -- The root hole which is the search target + root: MVarId + + -- Parent state metavariable source + parentMVar?: Option MVarId + + -- Existence of this field shows that we are currently in `conv` mode. + -- (convRhs, goal, dormant) + convMVar?: Option (MVarId × MVarId × List MVarId) := .none + -- Previous RHS for calc, so we don't have to repeat it every time + -- WARNING: If using `state with` outside of `calc`, this must be set to `.none` + calcPrevRhs?: Option (MVarId × Expr) := .none + +@[export pantograph_goal_state_create_m] +protected def GoalState.create (expr: Expr): Elab.TermElabM GoalState := do + -- May be necessary to immediately synthesise all metavariables if we need to leave the elaboration context. + -- See https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/Unknown.20universe.20metavariable/near/360130070 + + --Elab.Term.synthesizeSyntheticMVarsNoPostponing + --let expr ← instantiateMVars expr + let root ← Meta.mkFreshExprMVar expr (kind := MetavarKind.synthetic) (userName := .anonymous) + let savedStateMonad: Elab.Tactic.TacticM Elab.Tactic.SavedState := MonadBacktrack.saveState + let savedState ← savedStateMonad { elaborator := .anonymous } |>.run' { goals := [root.mvarId!]} + return { + root := root.mvarId!, + savedState, + parentMVar? := .none, + } +@[export pantograph_goal_state_create_from_mvars_m] +protected def GoalState.createFromMVars (goals: List MVarId) (root: MVarId): MetaM GoalState := do + let savedStateMonad: Elab.Tactic.TacticM Elab.Tactic.SavedState := MonadBacktrack.saveState + let savedState ← savedStateMonad { elaborator := .anonymous } |>.run' { goals } |>.run' {} + return { + root, + savedState, + parentMVar? := .none, + } +@[export pantograph_goal_state_is_conv] +protected def GoalState.isConv (state: GoalState): Bool := + state.convMVar?.isSome +protected def GoalState.goals (state: GoalState): List MVarId := + state.savedState.tactic.goals +@[export pantograph_goal_state_goals] +protected def GoalState.goalsArray (state: GoalState): Array MVarId := state.goals.toArray +protected def GoalState.mctx (state: GoalState): MetavarContext := + state.savedState.term.meta.meta.mctx +protected def GoalState.env (state: GoalState): Environment := + state.savedState.term.meta.core.env + +@[export pantograph_goal_state_meta_context_of_goal] +protected def GoalState.metaContextOfGoal (state: GoalState) (mvarId: MVarId): Option Meta.Context := do + let mvarDecl ← state.mctx.findDecl? mvarId + return { lctx := mvarDecl.lctx, localInstances := mvarDecl.localInstances } +protected def GoalState.metaState (state: GoalState): Meta.State := + state.savedState.term.meta.meta +protected def GoalState.coreState (state: GoalState): Core.SavedState := + state.savedState.term.meta.core + +protected def GoalState.withContext (state: GoalState) (mvarId: MVarId) (m: MetaM α): MetaM α := do + mvarId.withContext m |>.run' (← read) state.metaState + +protected def GoalState.withParentContext { n } [MonadControlT MetaM n] [Monad n] (state: GoalState): n α → n α := + Meta.mapMetaM <| state.withContext state.parentMVar?.get! +protected def GoalState.withRootContext { n } [MonadControlT MetaM n] [Monad n] (state: GoalState): n α → n α := + Meta.mapMetaM <| state.withContext state.root + +private def GoalState.mvars (state: GoalState): SSet MVarId := + state.mctx.decls.foldl (init := .empty) fun acc k _ => acc.insert k +protected def GoalState.restoreMetaM (state: GoalState): MetaM Unit := + state.savedState.term.meta.restore +protected def GoalState.restoreElabM (state: GoalState): Elab.TermElabM Unit := + state.savedState.term.restore +private def GoalState.restoreTacticM (state: GoalState) (goal: MVarId): Elab.Tactic.TacticM Unit := do + state.savedState.restore + Elab.Tactic.setGoals [goal] + +@[export pantograph_goal_state_focus] +protected def GoalState.focus (state: GoalState) (goalId: Nat): Option GoalState := do + let goal ← state.savedState.tactic.goals.get? goalId + return { + state with + savedState := { + state.savedState with + tactic := { goals := [goal] }, + }, + calcPrevRhs? := .none, + } + +/-- Immediately bring all parent goals back into scope. Used in automatic mode -/ +@[export pantograph_goal_state_immediate_resume_parent] +protected def GoalState.immediateResume (state: GoalState) (parent: GoalState): GoalState := + -- Prune parents solved goals + let mctx := state.mctx + let parentGoals := parent.goals.filter $ λ goal => mctx.eAssignment.contains goal + { + state with + savedState := { + state.savedState with + tactic := { goals := state.goals ++ parentGoals }, + }, + } + +/-- +Brings into scope a list of goals +-/ +@[export pantograph_goal_state_resume] +protected def GoalState.resume (state: GoalState) (goals: List MVarId): Except String GoalState := + if ¬ (goals.all (λ goal => state.mvars.contains goal)) then + let invalid_goals := goals.filter (λ goal => ¬ state.mvars.contains goal) |>.map (·.name.toString) + .error s!"Goals {invalid_goals} are not in scope" + else + -- Set goals to the goals that have not been assigned yet, similar to the `focus` tactic. + let unassigned := goals.filter (λ goal => + let mctx := state.mctx + ¬(mctx.eAssignment.contains goal || mctx.dAssignment.contains goal)) + .ok { + state with + savedState := { + term := state.savedState.term, + tactic := { goals := unassigned }, + }, + } +/-- +Brings into scope all goals from `branch` +-/ +@[export pantograph_goal_state_continue] +protected def GoalState.continue (target: GoalState) (branch: GoalState): Except String GoalState := + if !target.goals.isEmpty then + .error s!"Target state has unresolved goals" + else if target.root != branch.root then + .error s!"Roots of two continued goal states do not match: {target.root.name} != {branch.root.name}" + else + target.resume (goals := branch.goals) + +@[export pantograph_goal_state_root_expr] +protected def GoalState.rootExpr? (goalState: GoalState): Option Expr := do + if goalState.root.name == .anonymous then + .none + let expr ← goalState.mctx.eAssignment.find? goalState.root + let (expr, _) := instantiateMVarsCore (mctx := goalState.mctx) (e := expr) + if expr.hasExprMVar then + -- Must not assert that the goal state is empty here. We could be in a branch goal. + --assert! ¬goalState.goals.isEmpty + .none + else + assert! goalState.goals.isEmpty + return expr +@[export pantograph_goal_state_parent_expr] +protected def GoalState.parentExpr? (goalState: GoalState): Option Expr := do + let parent ← goalState.parentMVar? + let expr := goalState.mctx.eAssignment.find! parent + let (expr, _) := instantiateMVarsCore (mctx := goalState.mctx) (e := expr) + return expr +@[export pantograph_goal_state_get_mvar_e_assignment] +protected def GoalState.getMVarEAssignment (goalState: GoalState) (mvarId: MVarId): Option Expr := do + let expr ← goalState.mctx.eAssignment.find? mvarId + let (expr, _) := instantiateMVarsCore (mctx := goalState.mctx) (e := expr) + return expr + +--- Tactic execution functions --- + +-- Mimics `Elab.Term.logUnassignedUsingErrorInfos` +private def collectAllErroredMVars (src : MVarId) : Elab.TermElabM (List MVarId) := do + -- These descendants serve as "seed" mvars. If a MVarError's mvar is related + -- to one of these seed mvars, it means an error has occurred when a tactic + -- was executing on `src`. `evalTactic`, will not capture these mvars, so we + -- need to manually find them and save them into the goal list. + let descendants ← Meta.getMVars $ ← instantiateMVars (.mvar src) + --let _ ← Elab.Term.logUnassignedUsingErrorInfos descendants + let mut alreadyVisited : MVarIdSet := {} + let mut result : MVarIdSet := {} + for { mvarId, .. } in (← get).mvarErrorInfos do + unless alreadyVisited.contains mvarId do + alreadyVisited := alreadyVisited.insert mvarId + /- The metavariable `mvarErrorInfo.mvarId` may have been assigned or + delayed assigned to another metavariable that is unassigned. -/ + let mvarDeps ← Meta.getMVars (.mvar mvarId) + if mvarDeps.any descendants.contains then do + result := mvarDeps.foldl (·.insert ·) result + return result.toList + +private def mergeMVarLists (li1 li2 : List MVarId) : List MVarId := + let li2' := li2.filter (¬ li1.contains ·) + li1 ++ li2' + +/-- +Set `guardMVarErrors` to true to capture mvar errors. Lean will not +automatically collect mvars from text tactics (vide +`test_tactic_failure_synthesize_placeholder`) +-/ +protected def GoalState.step (state: GoalState) (goal: MVarId) (tacticM: Elab.Tactic.TacticM Unit) (guardMVarErrors : Bool := false) + : Elab.TermElabM GoalState := do + unless (← getMCtx).decls.contains goal do + throwError s!"Goal is not in context: {goal.name}" + goal.checkNotAssigned `GoalState.step + let (_, { goals }) ← tacticM { elaborator := .anonymous } |>.run { goals := [goal] } + let nextElabState ← MonadBacktrack.saveState + Elab.Term.synthesizeSyntheticMVarsNoPostponing + + let goals ← if guardMVarErrors then + pure $ mergeMVarLists goals (← collectAllErroredMVars goal) + else + pure goals + return { + state with + savedState := { term := nextElabState, tactic := { goals }, }, + parentMVar? := .some goal, + calcPrevRhs? := .none, + } + +/-- Response for executing a tactic -/ +inductive TacticResult where + -- Goes to next state + | success (state: GoalState) + -- Tactic failed with messages + | failure (messages: Array String) + -- Could not parse tactic + | parseError (message: String) + -- The given action cannot be executed in the state + | invalidAction (message: String) + +/-- Executes a `TacticM` monad on this `GoalState`, collecting the errors as necessary -/ +protected def GoalState.tryTacticM (state: GoalState) (goal: MVarId) (tacticM: Elab.Tactic.TacticM Unit) (guardMVarErrors : Bool := false): + Elab.TermElabM TacticResult := do + try + let nextState ← state.step goal tacticM guardMVarErrors + + -- Check if error messages have been generated in the core. + let newMessages ← (← Core.getMessageLog).toList.drop state.coreState.messages.toList.length + |>.filterMapM λ m => do + if m.severity == .error then + return .some $ ← m.toString + else + return .none + Core.resetMessageLog + if ¬ newMessages.isEmpty then + return .failure newMessages.toArray + return .success nextState + catch exception => + return .failure #[← exception.toMessageData.toString] + +/-- Execute a string tactic on given state. Restores TermElabM -/ +@[export pantograph_goal_state_try_tactic_m] +protected def GoalState.tryTactic (state: GoalState) (goal: MVarId) (tactic: String): + Elab.TermElabM TacticResult := do + state.restoreElabM + let tactic ← match Parser.runParserCategory + (env := ← MonadEnv.getEnv) + (catName := if state.isConv then `conv else `tactic) + (input := tactic) + (fileName := ← getFileName) with + | .ok stx => pure $ stx + | .error error => return .parseError error + state.tryTacticM goal (Elab.Tactic.evalTactic tactic) true + +protected def GoalState.tryAssign (state: GoalState) (goal: MVarId) (expr: String): + Elab.TermElabM TacticResult := do + state.restoreElabM + let expr ← match Parser.runParserCategory + (env := ← MonadEnv.getEnv) + (catName := `term) + (input := expr) + (fileName := ← getFileName) with + | .ok syn => pure syn + | .error error => return .parseError error + state.tryTacticM goal $ Tactic.evalAssign expr + +-- Specialized Tactics + +protected def GoalState.tryLet (state: GoalState) (goal: MVarId) (binderName: String) (type: String): + Elab.TermElabM TacticResult := do + state.restoreElabM + let type ← match Parser.runParserCategory + (env := ← MonadEnv.getEnv) + (catName := `term) + (input := type) + (fileName := ← getFileName) with + | .ok syn => pure syn + | .error error => return .parseError error + state.tryTacticM goal $ Tactic.evalLet binderName.toName type + +/-- Enter conv tactic mode -/ +protected def GoalState.conv (state: GoalState) (goal: MVarId): + Elab.TermElabM TacticResult := do + if state.convMVar?.isSome then + return .invalidAction "Already in conv state" + goal.checkNotAssigned `GoalState.conv + let tacticM : Elab.Tactic.TacticM (Elab.Tactic.SavedState × MVarId) := do + state.restoreTacticM goal + + -- See Lean.Elab.Tactic.Conv.convTarget + let convMVar ← Elab.Tactic.withMainContext do + let (rhs, newGoal) ← Elab.Tactic.Conv.mkConvGoalFor (← Elab.Tactic.getMainTarget) + Elab.Tactic.replaceMainGoal [newGoal.mvarId!] + pure rhs.mvarId! + return (← MonadBacktrack.saveState, convMVar) + try + let (nextSavedState, convRhs) ← tacticM { elaborator := .anonymous } |>.run' state.savedState.tactic + -- Other goals are now dormant + let otherGoals := state.goals.filter $ λ g => g != goal + return .success { + root := state.root, + savedState := nextSavedState + parentMVar? := .some goal, + convMVar? := .some (convRhs, goal, otherGoals), + calcPrevRhs? := .none + } + catch exception => + return .failure #[← exception.toMessageData.toString] + +/-- Exit from `conv` mode. Resumes all goals before the mode starts and applys the conv -/ +@[export pantograph_goal_state_conv_exit_m] +protected def GoalState.convExit (state: GoalState): + Elab.TermElabM TacticResult := do + let (convRhs, convGoal, _) ← match state.convMVar? with + | .some mvar => pure mvar + | .none => return .invalidAction "Not in conv state" + let tacticM : Elab.Tactic.TacticM Elab.Tactic.SavedState:= do + -- Vide `Lean.Elab.Tactic.Conv.convert` + state.savedState.restore + + -- Close all existing goals with `refl` + for mvarId in (← Elab.Tactic.getGoals) do + liftM <| mvarId.refl <|> mvarId.inferInstance <|> pure () + Elab.Tactic.pruneSolvedGoals + unless (← Elab.Tactic.getGoals).isEmpty do + throwError "convert tactic failed, there are unsolved goals\n{Elab.goalsToMessageData (← Elab.Tactic.getGoals)}" + + Elab.Tactic.setGoals [convGoal] + + let targetNew ← instantiateMVars (.mvar convRhs) + let proof ← instantiateMVars (.mvar convGoal) + + Elab.Tactic.liftMetaTactic1 fun mvarId => mvarId.replaceTargetEq targetNew proof + MonadBacktrack.saveState + try + let nextSavedState ← tacticM { elaborator := .anonymous } |>.run' state.savedState.tactic + return .success { + root := state.root, + savedState := nextSavedState + parentMVar? := .some convGoal, + convMVar? := .none + calcPrevRhs? := .none + } + catch exception => + return .failure #[← exception.toMessageData.toString] + +protected def GoalState.calcPrevRhsOf? (state: GoalState) (goal: MVarId): Option Expr := do + let (mvarId, rhs) ← state.calcPrevRhs? + if mvarId == goal then + .some rhs + else + .none +@[export pantograph_goal_state_try_calc_m] +protected def GoalState.tryCalc (state: GoalState) (goal: MVarId) (pred: String): + Elab.TermElabM TacticResult := do + state.restoreElabM + if state.convMVar?.isSome then + return .invalidAction "Cannot initiate `calc` while in `conv` state" + let `(term|$pred) ← match Parser.runParserCategory + (env := state.env) + (catName := `term) + (input := pred) + (fileName := ← getFileName) with + | .ok syn => pure syn + | .error error => return .parseError error + goal.checkNotAssigned `GoalState.tryCalc + let calcPrevRhs? := state.calcPrevRhsOf? goal + let decl ← goal.getDecl + let target ← instantiateMVars decl.type + let tag := decl.userName + try + goal.withContext do + + let mut step ← Elab.Term.elabType <| ← do + if let some prevRhs := calcPrevRhs? then + Elab.Term.annotateFirstHoleWithType pred (← Meta.inferType prevRhs) + else + pure pred + + let some (_, lhs, rhs) ← Elab.Term.getCalcRelation? step | + throwErrorAt pred "invalid 'calc' step, relation expected{indentExpr step}" + if let some prevRhs := calcPrevRhs? then + unless ← Meta.isDefEqGuarded lhs prevRhs do + throwErrorAt pred "invalid 'calc' step, left-hand-side is{indentD m!"{lhs} : {← Meta.inferType lhs}"}\nprevious right-hand-side is{indentD m!"{prevRhs} : {← Meta.inferType prevRhs}"}" + + -- Creates a mvar to represent the proof that the calc tactic solves the + -- current branch + -- In the Lean `calc` tactic this is gobbled up by + -- `withCollectingNewGoalsFrom` + let mut proof ← Meta.mkFreshExprMVarAt (← getLCtx) (← Meta.getLocalInstances) step + (userName := tag ++ `calc) + let mvarBranch := proof.mvarId! + + let mut proofType ← Meta.inferType proof + let mut remainder? := Option.none + + -- The calc tactic either solves the main goal or leaves another relation. + -- Replace the main goal, and save the new goal if necessary + unless ← Meta.isDefEq proofType target do + let rec throwFailed := + throwError "'calc' tactic failed, has type{indentExpr proofType}\nbut it is expected to have type{indentExpr target}" + let some (_, _, rhs) ← Elab.Term.getCalcRelation? proofType | throwFailed + let some (r, _, rhs') ← Elab.Term.getCalcRelation? target | throwFailed + let lastStep := mkApp2 r rhs rhs' + let lastStepGoal ← Meta.mkFreshExprSyntheticOpaqueMVar lastStep tag + (proof, proofType) ← Elab.Term.mkCalcTrans proof proofType lastStepGoal lastStep + unless ← Meta.isDefEq proofType target do throwFailed + remainder? := .some lastStepGoal.mvarId! + goal.assign proof + + let goals := [ mvarBranch ] ++ remainder?.toList + let calcPrevRhs? := remainder?.map $ λ g => (g, rhs) + return .success { + root := state.root, + savedState := { + term := ← MonadBacktrack.saveState, + tactic := { goals }, + }, + parentMVar? := .some goal, + calcPrevRhs? + } + catch exception => + return .failure #[← exception.toMessageData.toString] + +end Pantograph diff --git a/Pantograph/Library.lean b/Pantograph/Library.lean new file mode 100644 index 0000000..bb094b6 --- /dev/null +++ b/Pantograph/Library.lean @@ -0,0 +1,223 @@ +import Pantograph.Environment +import Pantograph.Goal +import Pantograph.Protocol +import Pantograph.Delate +import Pantograph.Version +import Lean + +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 ' = '" + let key := key.toName + 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 + +open Lean + +namespace Pantograph + +def runMetaM { α } (metaM: MetaM α): CoreM α := + metaM.run' +def runTermElabM { α } (termElabM: Elab.TermElabM α): CoreM α := + termElabM.run' (ctx := defaultElabContext) |>.run' + +def errorI (type desc: String): Protocol.InteractionError := { error := type, desc := desc } + +/-- Adds the given paths to Lean package search path -/ +@[export pantograph_init_search] +unsafe def initSearch (sp: String): IO Unit := do + Lean.enableInitializersExecution + Lean.initSearchPath (← Lean.findSysroot) (sp := System.SearchPath.parse sp) + +/-- Creates a Core.Context object needed to run all monads -/ +@[export pantograph_create_core_context] +def createCoreContext (options: Array String): IO Core.Context := do + let options? ← options.foldlM setOptionFromString' Options.empty |>.run + let options ← match options? with + | .ok options => pure options + | .error e => throw $ IO.userError s!"Options cannot be parsed: {e}" + return { + currNamespace := Name.str .anonymous "Aniva" + openDecls := [], -- No 'open' directives needed + fileName := "", + fileMap := { source := "", positions := #[0] }, + options := options + } + +/-- Creates a Core.State object needed to run all monads -/ +@[export pantograph_create_core_state] +def createCoreState (imports: Array String): IO Core.State := do + let env ← Lean.importModules + (imports := imports.map (λ str => { module := str.toName, runtimeOnly := false })) + (opts := {}) + (trustLevel := 1) + return { env := env } + +@[export pantograph_env_add_m] +def envAdd (name: String) (type: String) (value: String) (isTheorem: Bool): + CoreM (Protocol.CR Protocol.EnvAddResult) := + Environment.addDecl { name, type, value, isTheorem } + +@[export pantograph_parse_elab_type_m] +def parseElabType (type: String): Elab.TermElabM (Protocol.CR Expr) := do + let env ← MonadEnv.getEnv + let syn ← match parseTerm env type with + | .error str => return .error $ errorI "parsing" str + | .ok syn => pure syn + match ← elabType syn with + | .error str => return .error $ errorI "elab" str + | .ok expr => return .ok (← instantiateMVars expr) + +/-- This must be a TermElabM since the parsed expr contains extra information -/ +@[export pantograph_parse_elab_expr_m] +def parseElabExpr (expr: String) (expectedType?: Option String := .none): Elab.TermElabM (Protocol.CR Expr) := do + let env ← MonadEnv.getEnv + let expectedType? ← match ← expectedType?.mapM parseElabType with + | .none => pure $ .none + | .some (.ok t) => pure $ .some t + | .some (.error e) => return .error e + let syn ← match parseTerm env expr with + | .error str => return .error $ errorI "parsing" str + | .ok syn => pure syn + match ← elabTerm syn expectedType? with + | .error str => return .error $ errorI "elab" str + | .ok expr => return .ok (← instantiateMVars expr) + +@[export pantograph_expr_echo_m] +def exprEcho (expr: String) (expectedType?: Option String := .none) (levels: Array String := #[]) (options: @&Protocol.Options := {}): + CoreM (Protocol.CR Protocol.ExprEchoResult) := + runTermElabM $ Elab.Term.withLevelNames (levels.toList.map (·.toName)) do + let expr ← match ← parseElabExpr expr expectedType? with + | .error e => return .error e + | .ok expr => pure expr + try + let type ← unfoldAuxLemmas (← Meta.inferType expr) + return .ok { + type := (← serializeExpression options type), + expr := (← serializeExpression options expr) + } + catch exception => + return .error $ errorI "typing" (← exception.toMessageData.toString) + +@[export pantograph_goal_start_expr_m] +def goalStartExpr (expr: String) (levels: Array String): CoreM (Protocol.CR GoalState) := + runTermElabM $ Elab.Term.withLevelNames (levels.toList.map (·.toName)) do + let expr ← match ← parseElabType expr with + | .error e => return .error e + | .ok expr => pure $ expr + return .ok $ ← GoalState.create expr + +@[export pantograph_goal_resume] +def goalResume (target: GoalState) (goals: Array String): Except String GoalState := + target.resume (goals.map (λ n => { name := n.toName }) |>.toList) + +@[export pantograph_goal_serialize_m] +def goalSerialize (state: GoalState) (options: @&Protocol.Options): CoreM (Array Protocol.Goal) := + runMetaM <| state.serializeGoals (parent := .none) options + +@[export pantograph_goal_print_m] +def goalPrint (state: GoalState) (rootExpr: Bool) (parentExpr: Bool) (goals: Bool) (extraMVars : Array String) (options: @&Protocol.Options) + : CoreM Protocol.GoalPrintResult := runMetaM do + state.restoreMetaM + + let root? ← if rootExpr then + state.rootExpr?.mapM λ expr => state.withRootContext do + serializeExpression options (← instantiateAll expr) + else + pure .none + let parent? ← if parentExpr then + state.parentExpr?.mapM λ expr => state.withParentContext do + serializeExpression options (← instantiateAll expr) + else + pure .none + let goals ← if goals then + goalSerialize state options + else + pure #[] + let extraMVars ← extraMVars.mapM λ mvarId => do + let mvarId: MVarId := { name := mvarId.toName } + let .some _ ← mvarId.findDecl? | return {} + state.withContext mvarId do + let .some expr ← getExprMVarAssignment? mvarId | return {} + serializeExpression options (← instantiateAll expr) + return { + root?, + parent?, + goals, + extraMVars, + } + +@[export pantograph_goal_tactic_m] +def goalTactic (state: GoalState) (goal: MVarId) (tactic: String): CoreM TacticResult := + runTermElabM <| state.tryTactic goal tactic +@[export pantograph_goal_assign_m] +def goalAssign (state: GoalState) (goal: MVarId) (expr: String): CoreM TacticResult := + runTermElabM <| state.tryAssign goal expr +@[export pantograph_goal_have_m] +protected def GoalState.tryHave (state: GoalState) (goal: MVarId) (binderName: String) (type: String): CoreM TacticResult := do + let type ← match (← parseTermM type) with + | .ok syn => pure syn + | .error error => return .parseError error + runTermElabM do + state.restoreElabM + state.tryTacticM goal $ Tactic.evalHave binderName.toName type +@[export pantograph_goal_try_define_m] +protected def GoalState.tryDefine (state: GoalState) (goal: MVarId) (binderName: String) (expr: String): CoreM TacticResult := do + let expr ← match (← parseTermM expr) with + | .ok syn => pure syn + | .error error => return .parseError error + runTermElabM do + state.restoreElabM + state.tryTacticM goal (Tactic.evalDefine binderName.toName expr) +@[export pantograph_goal_try_motivated_apply_m] +protected def GoalState.tryMotivatedApply (state: GoalState) (goal: MVarId) (recursor: String): + Elab.TermElabM TacticResult := do + state.restoreElabM + let recursor ← match (← parseTermM recursor) with + | .ok syn => pure syn + | .error error => return .parseError error + state.tryTacticM goal (tacticM := Tactic.evalMotivatedApply recursor) +@[export pantograph_goal_try_no_confuse_m] +protected def GoalState.tryNoConfuse (state: GoalState) (goal: MVarId) (eq: String): + Elab.TermElabM TacticResult := do + state.restoreElabM + let eq ← match (← parseTermM eq) with + | .ok syn => pure syn + | .error error => return .parseError error + state.tryTacticM goal (tacticM := Tactic.evalNoConfuse eq) +@[export pantograph_goal_let_m] +def goalLet (state: GoalState) (goal: MVarId) (binderName: String) (type: String): CoreM TacticResult := + runTermElabM <| state.tryLet goal binderName type +@[export pantograph_goal_conv_m] +def goalConv (state: GoalState) (goal: MVarId): CoreM TacticResult := + runTermElabM <| state.conv goal +@[export pantograph_goal_conv_exit_m] +def goalConvExit (state: GoalState): CoreM TacticResult := + runTermElabM <| state.convExit +@[export pantograph_goal_calc_m] +def goalCalc (state: GoalState) (goal: MVarId) (pred: String): CoreM TacticResult := + runTermElabM <| state.tryCalc goal pred + +end Pantograph diff --git a/Pantograph/Meta.lean b/Pantograph/Meta.lean deleted file mode 100644 index 3426628..0000000 --- a/Pantograph/Meta.lean +++ /dev/null @@ -1,120 +0,0 @@ -import Lean - -import Pantograph.Symbols -import Pantograph.Serial - -/- -The proof state manipulation system - -A proof state is launched by providing -1. Environment: `Environment` -2. Expression: `Expr` -The expression becomes the first meta variable in the saved tactic state -`Elab.Tactic.SavedState`. -From this point on, any proof which extends -`Elab.Term.Context` and --/ - -def Lean.MessageLog.getErrorMessages (log : MessageLog) : MessageLog := -{ msgs := log.msgs.filter fun m => match m.severity with | MessageSeverity.error => true | _ => false } - - -namespace Pantograph -open Lean - -structure ProofState where - goals : List MVarId - savedState : Elab.Tactic.SavedState - parent : Option Nat := none - parentGoalId : Nat := 0 -structure ProofTree where - -- All parameters needed to run a `TermElabM` monad - name: Name - - -- Set of proof states - states : Array ProofState := #[] - -abbrev M := Elab.TermElabM - -def ProofTree.create (name: Name) (expr: Expr): M ProofTree := do - let expr ← instantiateMVars expr - let goal := (← Meta.mkFreshExprMVar expr (kind := MetavarKind.synthetic)) - let savedStateMonad: Elab.Tactic.TacticM Elab.Tactic.SavedState := MonadBacktrack.saveState - let savedState ← savedStateMonad { elaborator := .anonymous } |>.run' { goals := [goal.mvarId!]} - return { - name := name, - states := #[{ - savedState := savedState, - goals := [goal.mvarId!] - }] - } - --- Print the tree structures in readable form -def ProofTree.structure_array (tree: ProofTree): Array String := - tree.states.map λ state => match state.parent with - | .none => "" - | .some parent => s!"{parent}.{state.parentGoalId}" - -def execute_tactic (state: Elab.Tactic.SavedState) (goal: MVarId) (tactic: String) : - M (Except (Array String) (Elab.Tactic.SavedState × List MVarId)):= do - let tacticM (stx: Syntax): Elab.Tactic.TacticM (Except (Array String) (Elab.Tactic.SavedState × List MVarId)) := do - state.restore - Elab.Tactic.setGoals [goal] - try - Elab.Tactic.evalTactic stx - if (← getThe Core.State).messages.hasErrors then - let messages := (← getThe Core.State).messages.getErrorMessages |>.toList.toArray - let errors ← (messages.map Message.data).mapM fun md => md.toString - return .error errors - else - return .ok (← MonadBacktrack.saveState, ← Elab.Tactic.getUnsolvedGoals) - catch exception => - return .error #[← exception.toMessageData.toString] - match Parser.runParserCategory - (env := ← MonadEnv.getEnv) - (catName := `tactic) - (input := tactic) - (fileName := "") with - | Except.error err => return .error #[err] - | Except.ok stx => tacticM stx { elaborator := .anonymous } |>.run' state.tactic - -/-- Response for executing a tactic -/ -inductive TacticResult where - -- Invalid id - | invalid (message: String): TacticResult - -- Goes to next state - | success (nextId?: Option Nat) (goals: Array Goal) - -- Fails with messages - | failure (messages: Array String) - -/-- Execute tactic on given state -/ -def ProofTree.execute (stateId: Nat) (goalId: Nat) (tactic: String): StateRefT ProofTree M TacticResult := do - let tree ← get - match tree.states.get? stateId with - | .none => return .invalid s!"Invalid state id {stateId}" - | .some state => - match state.goals.get? goalId with - | .none => return .invalid s!"Invalid goal id {goalId}" - | .some goal => - match (← execute_tactic (state := state.savedState) (goal := goal) (tactic := tactic)) with - | .error errors => - return .failure errors - | .ok (nextState, nextGoals) => - let nextId := tree.states.size - if nextGoals.isEmpty then - return .success .none #[] - else - let proofState: ProofState := { - savedState := nextState, - goals := nextGoals, - parent := stateId, - parentGoalId := goalId - } - modify fun s => { s with states := s.states.push proofState } - let goals ← nextGoals.mapM fun mvarId => do - match (← MonadMCtx.getMCtx).findDecl? mvarId with - | .some mvarDecl => serialize_goal mvarDecl - | .none => throwError mvarId - return .success (.some nextId) goals.toArray - -end Pantograph diff --git a/Pantograph/Protocol.lean b/Pantograph/Protocol.lean new file mode 100644 index 0000000..90ac149 --- /dev/null +++ b/Pantograph/Protocol.lean @@ -0,0 +1,358 @@ +/- +All the command input/output structures are stored here + +Note that no command other than `InteractionError` may have `error` as one of +its field names to avoid confusion with error messages generated by the REPL. +-/ +import Lean.Data.Json + +namespace Pantograph.Protocol + + +/-- Main Option structure, placed here to avoid name collision -/ +structure Options where + -- When false, suppress newlines in Json objects. Useful for machine-to-machine interaction. + -- This should be false` by default to avoid any surprises with parsing. + printJsonPretty: Bool := false + -- When enabled, pretty print every expression + printExprPretty: Bool := true + -- When enabled, print the raw AST of expressions + printExprAST: Bool := false + printDependentMVars: Bool := false + -- When enabled, the types and values of persistent variables in a goal + -- are not shown unless they are new to the proof step. Reduces overhead. + -- NOTE: that this assumes the type and assignment of variables can never change. + noRepeat: Bool := false + -- See `pp.auxDecls` + printAuxDecls: Bool := false + -- See `pp.implementationDetailHyps` + printImplementationDetailHyps: Bool := false + -- If this is set to `true`, goals will never go dormant, so you don't have to manage resumption + automaticMode: Bool := true + deriving Lean.ToJson + +abbrev OptionsT := ReaderT Options + +--- 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 + dependentMVars?: Option (Array String) := .none + deriving Lean.ToJson + +structure Variable where + /-- The internal name used in raw expressions -/ + name: String := "" + /-- The name displayed to the user -/ + userName: String + /-- Does the name contain a dagger -/ + isInaccessible: Bool := false + type?: Option Expression := .none + value?: Option Expression := .none + deriving Lean.ToJson +structure Goal where + name: String := "" + /-- Name of the metavariable -/ + userName?: 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 + cmd: String + payload: Lean.Json + deriving Lean.FromJson + +structure InteractionError where + error: String + desc: String + deriving Lean.ToJson + +def errorIndex (desc: String): InteractionError := { error := "index", desc } +def errorExpr (desc: String): InteractionError := { error := "expr", desc } + + +--- Individual command and return types --- + + +structure Reset where + deriving Lean.FromJson +structure Stat where + deriving Lean.FromJson +structure StatResult where + -- Number of goals states + nGoals: Nat + deriving Lean.ToJson + +-- Return the type of an expression +structure ExprEcho where + expr: String + type?: Option String + -- universe levels + levels: Option (Array String) := .none + deriving Lean.FromJson +structure ExprEchoResult where + expr: Expression + type: Expression + deriving Lean.ToJson + +-- Print all symbols in environment +structure EnvCatalog where + deriving Lean.FromJson +structure EnvCatalogResult where + symbols: Array String + deriving Lean.ToJson + +-- Print the type of a symbol +structure EnvInspect where + 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 + -- If true, show the type and value dependencies + dependency?: Option Bool := .some false + deriving Lean.FromJson +-- See `InductiveVal` +structure InductInfo where + numParams: Nat + numIndices: Nat + all: Array String + ctors: Array String + isRec: Bool := false + isReflexive: Bool := false + isNested: Bool := false + deriving Lean.ToJson +-- See `ConstructorVal` +structure ConstructorInfo where + induct: String + cidx: Nat + numParams: Nat + numFields: Nat + deriving Lean.ToJson + +/-- See `Lean/Declaration.lean` -/ +structure RecursorRule where + ctor: String + nFields: Nat + rhs: Expression + deriving Lean.ToJson +structure RecursorInfo where + all: Array String + numParams: Nat + numIndices: Nat + numMotives: Nat + numMinors: Nat + rules: Array RecursorRule + k: Bool + deriving Lean.ToJson +structure EnvInspectResult where + type: Expression + isUnsafe: Bool := false + value?: Option Expression := .none + module?: Option String := .none + -- If the name is private, displays the public facing name + publicName?: Option String := .none + typeDependency?: Option (Array String) := .none + valueDependency?: Option (Array String) := .none + inductInfo?: Option InductInfo := .none + constructorInfo?: Option ConstructorInfo := .none + recursorInfo?: Option RecursorInfo := .none + deriving Lean.ToJson + +structure EnvAdd where + name: String + type: String + value: String + isTheorem: Bool + deriving Lean.FromJson +structure EnvAddResult where + 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 -/ +structure OptionsSet where + printJsonPretty?: Option Bool + printExprPretty?: Option Bool + printExprAST?: Option Bool + printDependentMVars?: Option Bool + noRepeat?: Option Bool + printAuxDecls?: Option Bool + printImplementationDetailHyps?: Option Bool + automaticMode?: Option Bool + deriving Lean.FromJson +structure OptionsSetResult where + deriving Lean.ToJson +structure OptionsPrint where + deriving Lean.FromJson + +structure GoalStart where + -- Only one of the fields below may be populated. + expr: Option String -- Directly parse in an expression + -- universe levels + levels: Option (Array String) := .none + copyFrom: Option String -- Copy the type from a theorem in the environment + deriving Lean.FromJson +structure GoalStartResult where + stateId: Nat := 0 + -- Name of the root metavariable + root: String + deriving Lean.ToJson +structure GoalTactic where + -- Identifiers for tree, state, and goal + stateId: Nat + goalId: Nat := 0 + -- One of the fields here must be filled + tactic?: Option String := .none + expr?: Option String := .none + have?: Option String := .none + let?: Option String := .none + calc?: Option String := .none + -- true to enter `conv`, `false` to exit. In case of exit the `goalId` is ignored. + conv?: Option Bool := .none + + -- In case of the `have` tactic, the new free variable name is provided here + binderName?: Option String := .none + + deriving Lean.FromJson +structure GoalTacticResult where + -- The next goal state id. Existence of this field shows success + nextStateId?: Option Nat := .none + -- If the array is empty, it shows the goals have been fully resolved. + goals?: Option (Array Goal) := .none + + -- Existence of this field shows tactic execution failure + tacticErrors?: Option (Array String) := .none + + -- Existence of this field shows the tactic parsing has failed + parseError?: Option String := .none + deriving Lean.ToJson +structure GoalContinue where + -- State from which the continuation acquires the context + target: Nat + + -- One of the following must be supplied + -- The state which is an ancestor of `target` where goals will be extracted from + branch?: Option Nat := .none + -- Or, the particular goals that should be brought back into scope + goals?: Option (Array String) := .none + deriving Lean.FromJson +structure GoalContinueResult where + nextStateId: Nat + goals: (Array Goal) + deriving Lean.ToJson + +-- Remove goal states +structure GoalDelete where + -- This is ok being a List because it doesn't show up in the ABI + stateIds: List Nat + deriving Lean.FromJson +structure GoalDeleteResult where + deriving Lean.ToJson + +structure GoalPrint where + stateId: Nat + + -- Print root? + rootExpr?: Option Bool := .some False + -- Print the parent expr? + parentExpr?: Option Bool := .some False + -- Print goals? + goals?: Option Bool := .some False + -- Print values of extra mvars? + extraMVars?: Option (Array String) := .none + deriving Lean.FromJson +structure GoalPrintResult where + -- The root expression + root?: Option Expression := .none + -- The filling expression of the parent goal + parent?: Option Expression := .none + goals: Array Goal := #[] + extraMVars: Array Expression := #[] + deriving Lean.ToJson + +-- Diagnostic Options, not available in REPL +structure GoalDiag where + printContext: Bool := true + printValue: Bool := true + printNewMVars: Bool := false + -- Print all mvars + printAll: Bool := false + instantiate: Bool := true + printSexp: Bool := false + +structure GoalSave where + id: Nat + path: System.FilePath + deriving Lean.FromJson +structure GoalSaveResult where + deriving Lean.ToJson +structure GoalLoad where + path: System.FilePath + deriving Lean.FromJson +structure GoalLoadResult where + id: Nat + deriving Lean.ToJson + + +/-- Executes the Lean compiler on a single file -/ +structure FrontendProcess where + -- One of these two must be supplied: Either supply the file name or the content. + fileName?: Option String := .none + file?: Option String := .none + -- If set to true, collect tactic invocations + invocations: Bool := false + -- If set to true, collect `sorry`s + sorrys: Bool := false + -- If set to true, extract new constants + newConstants: Bool := false + deriving Lean.FromJson +structure InvokedTactic where + goalBefore: String + goalAfter: String + tactic: String + + -- List of used constants + usedConstants: Array String + deriving Lean.ToJson + +structure CompilationUnit where + -- String boundaries of compilation units + boundary: (Nat × Nat) + messages: Array String := #[] + -- Tactic invocations + invocations?: Option (List InvokedTactic) := .none + goalStateId?: Option Nat := .none + goals?: Option (Array Goal) := .none + -- Code segments which generated the goals + goalSrcBoundaries?: Option (Array (Nat × Nat)) := .none + + -- New constants defined in compilation unit + newConstants?: Option (Array String) := .none + deriving Lean.ToJson +structure FrontendProcessResult where + units: List CompilationUnit + deriving Lean.ToJson + +abbrev CR α := Except InteractionError α + +end Pantograph.Protocol diff --git a/Pantograph/Serial.lean b/Pantograph/Serial.lean index 0d1c2d6..bd01169 100644 --- a/Pantograph/Serial.lean +++ b/Pantograph/Serial.lean @@ -1,120 +1,162 @@ -/- -All serialisation functions --/ -import Lean +import Lean.Environment +import Lean.Replay +import Init.System.IOError +import Std.Data.HashMap +import Pantograph.Goal + +/-! +Input/Output functions + +# Pickling and unpickling objects + +By abusing `saveModuleData` and `readModuleData` we can pickle and unpickle objects to disk. +-/ -namespace Pantograph open Lean +namespace Pantograph -/-- Read a theorem from the environment -/ -def expr_from_const (env: Environment) (name: Name): Except String Lean.Expr := - match env.find? name with - | none => throw s!"Symbol not found: {name}" - | some cInfo => return cInfo.type -def syntax_from_str (env: Environment) (s: String): Except String Syntax := - Parser.runParserCategory - (env := env) - (catName := `term) - (input := s) - (fileName := "") +/-- +Save an object to disk. +If you need to write multiple objects from within a single declaration, +you will need to provide a unique `key` for each. +-/ +def pickle {α : Type} (path : System.FilePath) (x : α) (key : Name := by exact decl_name%) : IO Unit := + saveModuleData path key (unsafe unsafeCast x) + +/-- +Load an object from disk. +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 +may cause crashes or other bad behavior. +-/ +unsafe def unpickle (α : Type) (path : System.FilePath) : IO (α × CompactedRegion) := do + let (x, region) ← readModuleData path + pure (unsafeCast x, region) + +/-- Load an object from disk and run some continuation on it, freeing memory afterwards. -/ +unsafe def withUnpickle [Monad m] [MonadLiftT IO m] {α β : Type} + (path : System.FilePath) (f : α → m β) : m β := do + let (x, region) ← unpickle α path + let r ← f x + region.free + pure r + +/-- +Pickle an `Environment` to disk. + +We only store: +* the list of imports +* the new constants from `Environment.constants` +and when unpickling, we build a fresh `Environment` from the imports, +and then add the new constants. +-/ +@[export pantograph_env_pickle_m] +def environmentPickle (env : Environment) (path : System.FilePath) : IO Unit := + Pantograph.pickle path (env.header.imports, env.constants.map₂) + +/-- +Unpickle an `Environment` from disk. + +We construct a fresh `Environment` with the relevant imports, +and then replace the new constants. +-/ +@[export pantograph_env_unpickle_m] +def environmentUnpickle (path : System.FilePath) : IO (Environment × CompactedRegion) := unsafe do + let ((imports, map₂), region) ← Pantograph.unpickle (Array Import × PHashMap Name ConstantInfo) path + let env ← importModules imports {} 0 + return (← env.replay (Std.HashMap.ofList map₂.toList), region) -def syntax_to_expr_type (syn: Syntax): Elab.TermElabM (Except String Expr) := do - try - let expr ← Elab.Term.elabType syn - -- Immediately synthesise all metavariables if we need to leave the elaboration context. - -- See https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/Unknown.20universe.20metavariable/near/360130070 - --Elab.Term.synthesizeSyntheticMVarsNoPostponing - let expr ← instantiateMVars expr - return .ok expr - catch ex => return .error (← ex.toMessageData.toString) -def syntax_to_expr (syn: Syntax): Elab.TermElabM (Except String Expr) := do - try - let expr ← Elab.Term.elabTerm (stx := syn) (expectedType? := .none) - -- Immediately synthesise all metavariables if we need to leave the elaboration context. - -- See https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/Unknown.20universe.20metavariable/near/360130070 - --Elab.Term.synthesizeSyntheticMVarsNoPostponing - let expr ← instantiateMVars expr - return .ok expr - catch ex => return .error (← ex.toMessageData.toString) +open Lean.Core in +structure CompactCoreState where + -- env : Environment + nextMacroScope : MacroScope := firstFrontendMacroScope + 1 + ngen : NameGenerator := {} + -- traceState : TraceState := {} + -- cache : Cache := {} + -- messages : MessageLog := {} + -- infoState : Elab.InfoState := {} -structure BoundExpression where - binders: Array (String × String) - target: String - deriving ToJson -def type_expr_to_bound (expr: Expr): MetaM 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) } - - -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 +@[export pantograph_goal_state_pickle_m] +def goalStatePickle (goalState : GoalState) (path : System.FilePath) : IO Unit := + let { + savedState := { + term := { + meta := { + core, + meta, } - | .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 + «elab», + }, + tactic } + root, + parentMVar?, + convMVar?, + calcPrevRhs?, + } := goalState + --let env := core.env + Pantograph.pickle path ( + ({ core with } : CompactCoreState), + meta, + «elab», + tactic, + + root, + parentMVar?, + convMVar?, + calcPrevRhs?, + ) + +@[export pantograph_goal_state_unpickle_m] +def goalStateUnpickle (path : System.FilePath) (env : Environment) + : IO (GoalState × CompactedRegion) := unsafe do + let (( + compactCore, + meta, + «elab», + tactic, + + root, + parentMVar?, + convMVar?, + calcPrevRhs?, + ), region) ← Pantograph.unpickle ( + CompactCoreState × + Meta.State × + Elab.Term.State × + Elab.Tactic.State × + + MVarId × + Option MVarId × + Option (MVarId × MVarId × List MVarId) × + Option (MVarId × Expr) + ) path + let goalState := { + savedState := { + term := { + meta := { + core := { + compactCore with + passedHeartbeats := 0, + env, + }, + meta, + }, + «elab», + }, + tactic, + }, + root, + parentMVar?, + convMVar?, + calcPrevRhs?, + } + return (goalState, region) end Pantograph diff --git a/Pantograph/Symbols.lean b/Pantograph/Symbols.lean deleted file mode 100644 index 641a276..0000000 --- a/Pantograph/Symbols.lean +++ /dev/null @@ -1,38 +0,0 @@ -/- - - Manages the visibility status of symbols - -/ -import Lean.Declaration - -namespace Pantograph - -def str_to_name (s: String): Lean.Name := - (s.splitOn ".").foldl Lean.Name.str Lean.Name.anonymous - -def is_symbol_unsafe_or_internal (n: Lean.Name) (info: Lean.ConstantInfo): Bool := - let nameDeduce: Bool := match n.getRoot with - | .str _ name => name.startsWith "_" ∨ name == "Lean" - | _ => true - let stemDeduce: Bool := match n with - | .anonymous => true - | .str _ name => name.startsWith "_" - | .num _ _ => true - nameDeduce ∨ stemDeduce ∨ info.isUnsafe - -def to_compact_symbol_name (n: Lean.Name) (info: Lean.ConstantInfo): String := - let pref := match info with - | .axiomInfo _ => "axiom" - | .defnInfo _ => "defn" - | .thmInfo _ => "thm" - | .opaqueInfo _ => "opaque" - | .quotInfo _ => "quot" - | .inductInfo _ => "induct" - | .ctorInfo _ => "ctor" - | .recInfo _ => "rec" - s!"{pref}|{toString n}" - -def to_filtered_symbol (n: Lean.Name) (info: Lean.ConstantInfo): Option String := - if is_symbol_unsafe_or_internal n info - then Option.none - else Option.some <| to_compact_symbol_name n info - -end Pantograph diff --git a/Pantograph/Tactic.lean b/Pantograph/Tactic.lean new file mode 100644 index 0000000..72902f4 --- /dev/null +++ b/Pantograph/Tactic.lean @@ -0,0 +1,5 @@ +import Pantograph.Tactic.Assign +import Pantograph.Tactic.Congruence +import Pantograph.Tactic.MotivatedApply +import Pantograph.Tactic.NoConfuse +import Pantograph.Tactic.Prograde diff --git a/Pantograph/Tactic/Assign.lean b/Pantograph/Tactic/Assign.lean new file mode 100644 index 0000000..8a5b998 --- /dev/null +++ b/Pantograph/Tactic/Assign.lean @@ -0,0 +1,31 @@ +import Lean + +open Lean + +namespace Pantograph.Tactic + +/-- WARNING: This should be used with a function like `elabTermWithHoles` that properly collects the mvar information from `expr`. -/ +def assign (goal: MVarId) (expr: Expr) (nextGoals: List MVarId): MetaM (List MVarId) := do + goal.checkNotAssigned `Pantograph.Tactic.assign + + -- This run of the unifier is critical in resolving mvars in passing + let exprType ← Meta.inferType expr + let goalType ← goal.getType + unless ← Meta.isDefEq goalType exprType do + throwError s!"{← Meta.ppExpr expr} : {← Meta.ppExpr exprType} ≠ {← Meta.ppExpr goalType}" + goal.assign expr + nextGoals.filterM (not <$> ·.isAssigned) + +def evalAssign : Elab.Tactic.Tactic := fun stx => Elab.Tactic.withMainContext do + let target ← Elab.Tactic.getMainTarget + let goal ← Elab.Tactic.getMainGoal + goal.checkNotAssigned `Pantograph.Tactic.evalAssign + let (expr, nextGoals) ← Elab.Tactic.elabTermWithHoles stx + (expectedType? := .some target) + (tagSuffix := .anonymous ) + (allowNaturalHoles := true) + goal.assign expr + Elab.Tactic.replaceMainGoal nextGoals + + +end Pantograph.Tactic diff --git a/Pantograph/Tactic/Congruence.lean b/Pantograph/Tactic/Congruence.lean new file mode 100644 index 0000000..0f6d80d --- /dev/null +++ b/Pantograph/Tactic/Congruence.lean @@ -0,0 +1,98 @@ +import Lean + +open Lean + +namespace Pantograph.Tactic + +def congruenceArg (mvarId: MVarId): MetaM (List MVarId) := mvarId.withContext do + mvarId.checkNotAssigned `Pantograph.Tactic.congruenceArg + let target ← mvarId.getType + let .some (β, _, _) := (← instantiateMVars target).eq? | throwError "Goal is not an Eq" + let userName := (← mvarId.getDecl).userName + + let u ← Meta.mkFreshLevelMVar + let α ← Meta.mkFreshExprSyntheticOpaqueMVar (mkSort u) + (tag := userName ++ `α) + let f ← Meta.mkFreshExprSyntheticOpaqueMVar (.forallE .anonymous α β .default) + (tag := userName ++ `f) + let a₁ ← Meta.mkFreshExprSyntheticOpaqueMVar α + (tag := userName ++ `a₁) + let a₂ ← Meta.mkFreshExprSyntheticOpaqueMVar α + (tag := userName ++ `a₂) + let h ← Meta.mkFreshExprSyntheticOpaqueMVar (← Meta.mkEq a₁ a₂) + (tag := userName ++ `h) + let conduitType ← Meta.mkEq (← Meta.mkEq (.app f a₁) (.app f a₂)) target + let conduit ← Meta.mkFreshExprSyntheticOpaqueMVar conduitType + (tag := userName ++ `conduit) + mvarId.assign $ ← Meta.mkEqMP conduit (← Meta.mkCongrArg f h) + let result := [α, a₁, a₂, f, h, conduit] + return result.map (·.mvarId!) + +def evalCongruenceArg: Elab.Tactic.TacticM Unit := do + let goal ← Elab.Tactic.getMainGoal + let nextGoals ← congruenceArg goal + Elab.Tactic.replaceMainGoal nextGoals + +def congruenceFun (mvarId: MVarId): MetaM (List MVarId) := mvarId.withContext do + mvarId.checkNotAssigned `Pantograph.Tactic.congruenceFun + let target ← mvarId.getType + let .some (β, _, _) := (← instantiateMVars target).eq? | throwError "Goal is not an Eq" + let userName := (← mvarId.getDecl).userName + let u ← Meta.mkFreshLevelMVar + let α ← Meta.mkFreshExprSyntheticOpaqueMVar (mkSort u) + (tag := userName ++ `α) + let fType := .forallE .anonymous α β .default + let f₁ ← Meta.mkFreshExprSyntheticOpaqueMVar fType + (tag := userName ++ `f₁) + let f₂ ← Meta.mkFreshExprSyntheticOpaqueMVar fType + (tag := userName ++ `f₂) + let a ← Meta.mkFreshExprSyntheticOpaqueMVar α + (tag := userName ++ `a) + let h ← Meta.mkFreshExprSyntheticOpaqueMVar (← Meta.mkEq f₁ f₂) + (tag := userName ++ `h) + let conduitType ← Meta.mkEq (← Meta.mkEq (.app f₁ a) (.app f₂ a)) target + let conduit ← Meta.mkFreshExprSyntheticOpaqueMVar conduitType + (tag := userName ++ `conduit) + mvarId.assign $ ← Meta.mkEqMP conduit (← Meta.mkCongrFun h a) + let result := [α, f₁, f₂, h, a, conduit] + return result.map (·.mvarId!) + +def evalCongruenceFun: Elab.Tactic.TacticM Unit := do + let goal ← Elab.Tactic.getMainGoal + let nextGoals ← congruenceFun goal + Elab.Tactic.replaceMainGoal nextGoals + +def congruence (mvarId: MVarId): MetaM (List MVarId) := mvarId.withContext do + mvarId.checkNotAssigned `Pantograph.Tactic.congruence + let target ← mvarId.getType + let .some (β, _, _) := (← instantiateMVars target).eq? | throwError "Goal is not an Eq" + let userName := (← mvarId.getDecl).userName + let u ← Meta.mkFreshLevelMVar + let α ← Meta.mkFreshExprSyntheticOpaqueMVar (mkSort u) + (tag := userName ++ `α) + let fType := .forallE .anonymous α β .default + let f₁ ← Meta.mkFreshExprSyntheticOpaqueMVar fType + (tag := userName ++ `f₁) + let f₂ ← Meta.mkFreshExprSyntheticOpaqueMVar fType + (tag := userName ++ `f₂) + let a₁ ← Meta.mkFreshExprSyntheticOpaqueMVar α + (tag := userName ++ `a₁) + let a₂ ← Meta.mkFreshExprSyntheticOpaqueMVar α + (tag := userName ++ `a₂) + let h₁ ← Meta.mkFreshExprSyntheticOpaqueMVar (← Meta.mkEq f₁ f₂) + (tag := userName ++ `h₁) + let h₂ ← Meta.mkFreshExprSyntheticOpaqueMVar (← Meta.mkEq a₁ a₂) + (tag := userName ++ `h₂) + let conduitType ← Meta.mkEq (← Meta.mkEq (.app f₁ a₁) (.app f₂ a₂)) target + let conduit ← Meta.mkFreshExprSyntheticOpaqueMVar conduitType + (tag := userName ++ `conduit) + mvarId.assign $ ← Meta.mkEqMP conduit (← Meta.mkCongr h₁ h₂) + let result := [α, f₁, f₂, a₁, a₂, h₁, h₂, conduit] + return result.map (·.mvarId!) + +def evalCongruence: Elab.Tactic.TacticM Unit := do + let goal ← Elab.Tactic.getMainGoal + let nextGoals ← congruence goal + Elab.Tactic.replaceMainGoal nextGoals + +end Pantograph.Tactic diff --git a/Pantograph/Tactic/MotivatedApply.lean b/Pantograph/Tactic/MotivatedApply.lean new file mode 100644 index 0000000..993d287 --- /dev/null +++ b/Pantograph/Tactic/MotivatedApply.lean @@ -0,0 +1,106 @@ +import Lean + +open Lean + +namespace Pantograph.Tactic + +def getForallArgsBody: Expr → List Expr × Expr + | .forallE _ d b _ => + let (innerArgs, innerBody) := getForallArgsBody b + (d :: innerArgs, innerBody) + | e => ([], e) + +def replaceForallBody: Expr → Expr → Expr + | .forallE param domain body binderInfo, target => + let body := replaceForallBody body target + .forallE param domain body binderInfo + | _, target => target + +structure RecursorWithMotive where + args: List Expr + body: Expr + + -- .bvar index for the motive and major from the body + iMotive: Nat + +namespace RecursorWithMotive + +protected def nArgs (info: RecursorWithMotive): Nat := info.args.length + +protected def getMotiveType (info: RecursorWithMotive): Expr := + let level := info.nArgs - info.iMotive - 1 + let a := info.args.get! level + a + +protected def surrogateMotiveType (info: RecursorWithMotive) (mvars: Array Expr) (resultant: Expr): MetaM Expr := do + let motiveType := Expr.instantiateRev info.getMotiveType mvars + let resultantType ← Meta.inferType resultant + return replaceForallBody motiveType resultantType + +protected def conduitType (info: RecursorWithMotive) (mvars: Array Expr) (resultant: Expr): MetaM Expr := do + let motiveCall := Expr.instantiateRev info.body mvars + Meta.mkEq motiveCall resultant + +end RecursorWithMotive + +def getRecursorInformation (recursorType: Expr): Option RecursorWithMotive := do + let (args, body) := getForallArgsBody recursorType + if ¬ body.isApp then + .none + let iMotive ← match body.getAppFn with + | .bvar iMotive => pure iMotive + | _ => .none + return { + args, + body, + iMotive, + } + +def collectMotiveArguments (forallBody: Expr): SSet Nat := + match forallBody with + | .app (.bvar i) _ => SSet.empty.insert i + | _ => SSet.empty + +/-- Applies a symbol of the type `∀ (motive: α → Sort u) (a: α)..., (motive α)` -/ +def motivatedApply (mvarId: MVarId) (recursor: Expr) : MetaM (Array Meta.InductionSubgoal) := mvarId.withContext do + mvarId.checkNotAssigned `Pantograph.Tactic.motivatedApply + let recursorType ← Meta.inferType recursor + let resultant ← mvarId.getType + let tag ← mvarId.getTag + + let info ← match getRecursorInformation recursorType with + | .some info => pure info + | .none => throwError "Recursor return type does not correspond with the invocation of a motive: {← Meta.ppExpr recursorType}" + + let rec go (i: Nat) (prev: Array Expr): MetaM (Array Expr) := do + if i ≥ info.nArgs then + return prev + else + let argType := info.args.get! i + -- If `argType` has motive references, its goal needs to be placed in it + let argType := argType.instantiateRev prev + let bvarIndex := info.nArgs - i - 1 + let argGoal ← if bvarIndex = info.iMotive then + let surrogateMotiveType ← info.surrogateMotiveType prev resultant + Meta.mkFreshExprSyntheticOpaqueMVar surrogateMotiveType (tag := tag ++ `motive) + else + Meta.mkFreshExprSyntheticOpaqueMVar argType (tag := .anonymous) + let prev := prev ++ [argGoal] + go (i + 1) prev + termination_by info.nArgs - i + let mut newMVars ← go 0 #[] + + -- Create the conduit type which proves the result of the motive is equal to the goal + let conduitType ← info.conduitType newMVars resultant + let goalConduit ← Meta.mkFreshExprSyntheticOpaqueMVar conduitType (tag := `conduit) + mvarId.assign $ ← Meta.mkEqMP goalConduit (mkAppN recursor newMVars) + newMVars := newMVars ++ [goalConduit] + + return newMVars.map (λ mvar => { mvarId := mvar.mvarId!}) + +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.replaceMainGoal $ nextGoals.toList.map (·.mvarId) + +end Pantograph.Tactic diff --git a/Pantograph/Tactic/NoConfuse.lean b/Pantograph/Tactic/NoConfuse.lean new file mode 100644 index 0000000..e9ff459 --- /dev/null +++ b/Pantograph/Tactic/NoConfuse.lean @@ -0,0 +1,22 @@ +import Lean + +open Lean + +namespace Pantograph.Tactic + +def noConfuse (mvarId: MVarId) (h: Expr): MetaM Unit := mvarId.withContext do + mvarId.checkNotAssigned `Pantograph.Tactic.noConfuse + let target ← mvarId.getType + let noConfusion ← Meta.mkNoConfusion (target := target) (h := h) + + 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 target}" + 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.replaceMainGoal [] + +end Pantograph.Tactic diff --git a/Pantograph/Tactic/Prograde.lean b/Pantograph/Tactic/Prograde.lean new file mode 100644 index 0000000..0b4719f --- /dev/null +++ b/Pantograph/Tactic/Prograde.lean @@ -0,0 +1,88 @@ +/- Prograde (forward) reasoning tactics -/ + +import Lean +open Lean + +namespace Pantograph.Tactic + +private def mkUpstreamMVar (goal: MVarId) : MetaM Expr := do + Meta.mkFreshExprSyntheticOpaqueMVar (← goal.getType) (tag := ← goal.getTag) + + +/-- Introduces a fvar to the current mvar -/ +def define (mvarId: MVarId) (binderName: Name) (expr: Expr): MetaM (FVarId × MVarId) := mvarId.withContext do + mvarId.checkNotAssigned `Pantograph.Tactic.define + let type ← Meta.inferType expr + + Meta.withLetDecl binderName type expr λ fvar => do + let mvarUpstream ← mkUpstreamMVar mvarId + mvarId.assign $ ← Meta.mkLetFVars #[fvar] mvarUpstream + pure (fvar.fvarId!, mvarUpstream.mvarId!) + +def evalDefine (binderName: Name) (expr: Syntax): Elab.Tactic.TacticM Unit := do + let goal ← Elab.Tactic.getMainGoal + let expr ← goal.withContext $ Elab.Term.elabTerm (stx := expr) (expectedType? := .none) + let (_, mvarId) ← define goal binderName expr + Elab.Tactic.replaceMainGoal [mvarId] + +structure BranchResult where + fvarId?: Option FVarId := .none + branch: MVarId + main: MVarId + +def «have» (mvarId: MVarId) (binderName: Name) (type: Expr): MetaM BranchResult := mvarId.withContext do + mvarId.checkNotAssigned `Pantograph.Tactic.have + let lctx ← MonadLCtx.getLCtx + -- The branch goal inherits the same context, but with a different type + let mvarBranch ← Meta.mkFreshExprMVarAt lctx (← Meta.getLocalInstances) type + + -- Create the context for the `upstream` goal + let fvarId ← mkFreshFVarId + let lctxUpstream := lctx.mkLocalDecl fvarId binderName type + let mvarUpstream ← + withTheReader Meta.Context (fun ctx => { ctx with lctx := lctxUpstream }) do + Meta.withNewLocalInstances #[.fvar fvarId] 0 do + let mvarUpstream ← mkUpstreamMVar mvarId + --let expr: Expr := .app (.lam binderName type mvarBranch .default) mvarUpstream + mvarId.assign $ ← Meta.mkLambdaFVars #[.fvar fvarId] mvarUpstream + pure mvarUpstream + + return { + fvarId? := .some fvarId, + branch := mvarBranch.mvarId!, + main := mvarUpstream.mvarId!, + } + +def evalHave (binderName: Name) (type: Syntax): Elab.Tactic.TacticM Unit := do + let goal ← Elab.Tactic.getMainGoal + let nextGoals: List MVarId ← goal.withContext do + let type ← Elab.Term.elabType (stx := type) + let result ← «have» goal binderName type + pure [result.branch, result.main] + Elab.Tactic.replaceMainGoal nextGoals + +def «let» (mvarId: MVarId) (binderName: Name) (type: Expr): MetaM BranchResult := mvarId.withContext do + mvarId.checkNotAssigned `Pantograph.Tactic.let + let lctx ← MonadLCtx.getLCtx + + -- The branch goal inherits the same context, but with a different type + let mvarBranch ← Meta.mkFreshExprMVarAt lctx (← Meta.getLocalInstances) type (userName := binderName) + + assert! ¬ type.hasLooseBVars + let mvarUpstream ← Meta.withLetDecl binderName type mvarBranch $ λ fvar => do + let mvarUpstream ← mkUpstreamMVar mvarId + mvarId.assign $ ← Meta.mkLetFVars #[fvar] mvarUpstream + pure mvarUpstream + + return { + branch := mvarBranch.mvarId!, + main := mvarUpstream.mvarId!, + } + +def evalLet (binderName: Name) (type: Syntax): Elab.Tactic.TacticM Unit := do + let goal ← Elab.Tactic.getMainGoal + let type ← goal.withContext $ Elab.Term.elabType (stx := type) + let result ← «let» goal binderName type + Elab.Tactic.replaceMainGoal [result.branch, result.main] + +end Pantograph.Tactic diff --git a/Pantograph/Version.lean b/Pantograph/Version.lean new file mode 100644 index 0000000..9d044d4 --- /dev/null +++ b/Pantograph/Version.lean @@ -0,0 +1,6 @@ +namespace Pantograph + +@[export pantograph_version] +def version := "0.2.23" + +end Pantograph diff --git a/README.md b/README.md index 68ea647..02de68c 100644 --- a/README.md +++ b/README.md @@ -1,89 +1,130 @@ # Pantograph -An interaction system for Lean 4. +A Machine-to-Machine interaction system for Lean 4. ![Pantograph](doc/icon.svg) +Pantograph provides interfaces to execute proofs, construct expressions, and +examine the symbol list of a Lean project for machine learning. + +See [documentations](doc/rationale.md) for design rationale and references. + ## Installation -Install `elan` and `lean4`. Then, execute +For Nix users, run +``` sh +nix build .#{sharedLib,executable} +``` +to build either the shared library or executable. + +Install `lake` and `lean` fixed to the version of the `lean-toolchain` file, and +run + ``` sh lake build ``` -Then, setup the `LEAN_PATH` environment variable so it contains the library path of lean libraries. The libraries must be built in advance. For example, if `mathlib4` is stored at `../lib/mathlib4`, -``` sh -LIB="../lib" -LIB_MATHLIB="$LIB/mathlib4/lake-packages" -export LEAN_PATH="$LIB/mathlib4/build/lib:$LIB_MATHLIB/aesop/build/lib:$LIB_MATHLIB/Qq/build/lib:$LIB_MATHLIB/std/build/lib" +This builds the executable in `.lake/build/bin/pantograph-repl`. -LEAN_PATH=$LEAN_PATH build/bin/pantograph $@ -``` -Note that `lean-toolchain` must be present in the `$PWD` in order to run Pantograph! This is because Pantograph taps into Lean's internals. - -## Usage +## Executable Usage ``` sh -build/bin/pantograph OPTIONS|MODULES +pantograph-repl MODULES|LEAN_OPTIONS ``` +The `pantograph-repl` executable must be run with a list of modules to import. +It can also accept lean options of the form `--key=value` e.g. `--pp.raw=true`. + The REPL loop accepts commands as single-line JSON inputs and outputs either an -`Error:` (indicating malformed command) or a json return value indicating the +`Error:` (indicating malformed command) or a JSON return value indicating the result of a command execution. The command can be passed in one of two formats ``` command { ... } { "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/Protocol.lean` and below. An empty command aborts the REPL. -The `Pantograph` executable must be run with a list of modules to import. It can -also accept options of the form `--key=value` e.g. `--pp.raw=true`. Example: (~5k symbols) ``` -$ build/bin/Pantograph Init -catalog -inspect {"name": "Nat.le_add_left"} +$ pantograph Init +env.catalog +env.inspect {"name": "Nat.le_add_left"} ``` Example with `mathlib4` (~90k symbols, may stack overflow, see troubleshooting) ``` -$ lake env build/bin/Pantograph Mathlib.Analysis.Seminorm -catalog +$ pantograph Mathlib.Analysis.Seminorm +env.catalog ``` -Example proving a theorem: (alternatively use `proof.start {"copyFrom": "Nat.add_comm"}`) to prime the proof +Example proving a theorem: (alternatively use `goal.start {"copyFrom": "Nat.add_comm"}`) to prime the proof ``` -$ env build/bin/Pantograph Init -proof.start {"expr": "∀ (n m : Nat), n + m = m + n"} -proof.tactic {"treeId": 0, "stateId": 0, "goalId": 0, "tactic": "intro n m"} -proof.tactic {"treeId": 0, "stateId": 1, "goalId": 0, "tactic": "assumption"} -proof.printTree {"treeId": 0} -proof.tactic {"treeId": 0, "stateId": 1, "goalId": 0, "tactic": "rw [Nat.add_comm]"} -proof.printTree {"treeId": 0} +$ pantograph Init +goal.start {"expr": "∀ (n m : Nat), n + m = m + n"} +goal.tactic {"stateId": 0, "goalId": 0, "tactic": "intro n m"} +goal.tactic {"stateId": 1, "goalId": 0, "tactic": "assumption"} +goal.delete {"stateIds": [0]} +stat {} +goal.tactic {"stateId": 1, "goalId": 0, "tactic": "rw [Nat.add_comm]"} +stat ``` where the application of `assumption` should lead to a failure. -## Commands +For a list of commands, see [REPL Documentation](doc/repl.md). -See `Pantograph/Commands.lean` for a description of the parameters and return values in Json. -- `catalog`: Display a list of all safe Lean symbols in the current context -- `inspect {"name": }`: Show the type and package of a given symbol -- `clear`: Delete all cached expressions and proof trees -- `expr.type {"expr": }`: Determine the type of an expression and round-trip it -- `proof.start {["name": ], ["expr": ], ["copyFrom": ]}`: Start a new proof state from a given expression or symbol -- `proof.tactic {"treeId": , "stateId": , "goalId": , "tactic": string}`: Execute a tactic on a given proof state -- `proof.printTree {"treeId": }`: Print the topological structure of a proof tree +### Project Environment -## Troubleshooting +To use Pantograph in a project environment, setup the `LEAN_PATH` environment +variable so it contains the library path of lean libraries. The libraries must +be built in advance. For example, if `mathlib4` is stored at `../lib/mathlib4`, +the environment might be setup like this: + +``` sh +LIB="../lib" +LIB_MATHLIB="$LIB/mathlib4/.lake" +export LEAN_PATH="$LIB/mathlib4/build/lib:$LIB_MATHLIB/aesop/build/lib:$LIB_MATHLIB/Qq/build/lib:$LIB_MATHLIB/std/build/lib" + +LEAN_PATH=$LEAN_PATH build/bin/pantograph $@ +``` +The `$LEAN_PATH` executable of any project can be extracted by +``` sh +lake env printenv LEAN_PATH +``` + +### Troubleshooting If lean encounters stack overflow problems when printing catalog, execute this before running lean: ```sh ulimit -s unlimited ``` -## Testing +## Library Usage -The tests are based on `LSpec`. To run tests, +`Pantograph/Library.lean` exposes a series of interfaces which allow FFI call +with `Pantograph` which mirrors the REPL commands above. It is recommended to +call Pantograph via this FFI since it provides a tremendous speed up. + +The executable can be used as-is, but linking against the shared library +requires the presence of `lean-all`. Note that there isn't a 1-1 correspondence +between executable (REPL) commands and library functions. + +Inject any project path via the `pantograph_init_search` function. + +## Developing + +A Lean development shell is provided in the Nix flake. + +### Testing + +The tests are based on `LSpec`. To run tests, use either ``` sh -test/all.sh +nix flake check ``` +or +``` sh +lake test +``` +You can run an individual test by specifying a prefix +``` sh +lake test -- "Tactic/No Confuse" +``` diff --git a/Repl.lean b/Repl.lean new file mode 100644 index 0000000..eb02f59 --- /dev/null +++ b/Repl.lean @@ -0,0 +1,304 @@ +import Std.Data.HashMap +import Pantograph + +namespace Pantograph.Repl + +structure Context where + imports: List String + +/-- Stores state of the REPL -/ +structure State where + options: Protocol.Options := {} + nextId: Nat := 0 + goalStates: Std.HashMap Nat GoalState := Std.HashMap.empty + +/-- Main state monad for executing commands -/ +abbrev MainM := ReaderT Context (StateT State Lean.CoreM) + +def newGoalState (goalState: GoalState) : MainM Nat := do + let state ← get + let stateId := state.nextId + set { state with + goalStates := state.goalStates.insert stateId goalState, + nextId := state.nextId + 1 + } + return stateId + + +-- HACK: For some reason writing `CommandM α := MainM (Except ... α)` disables +-- certain monadic features in `MainM` +abbrev CR α := Except Protocol.InteractionError α + +def runMetaInMainM { α } (metaM: Lean.MetaM α): MainM α := + metaM.run' +def runTermElabInMainM { α } (termElabM: Lean.Elab.TermElabM α) : MainM α := + termElabM.run' (ctx := defaultElabContext) |>.run' + +/-- Main loop command of the REPL -/ +def execute (command: Protocol.Command): MainM Lean.Json := do + let run { α β: Type } [Lean.FromJson α] [Lean.ToJson β] (comm: α → MainM (CR β)): MainM Lean.Json := + match Lean.fromJson? command.payload with + | .ok args => do + match (← comm args) with + | .ok result => return Lean.toJson result + | .error ierror => return Lean.toJson ierror + | .error error => return Lean.toJson $ errorCommand s!"Unable to parse json: {error}" + try + match command.cmd with + | "reset" => run reset + | "stat" => run stat + | "expr.echo" => run expr_echo + | "env.catalog" => run env_catalog + | "env.inspect" => run env_inspect + | "env.add" => run env_add + | "env.save" => run env_save + | "env.load" => run env_load + | "options.set" => run options_set + | "options.print" => run options_print + | "goal.start" => run goal_start + | "goal.tactic" => run goal_tactic + | "goal.continue" => run goal_continue + | "goal.delete" => run goal_delete + | "goal.print" => run goal_print + | "goal.save" => run goal_save + | "goal.load" => run goal_load + | "frontend.process" => run frontend_process + | cmd => + 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 + errorCommand := errorI "command" + errorIndex := errorI "index" + errorIO := errorI "io" + -- Command Functions + reset (_: Protocol.Reset): MainM (CR Protocol.StatResult) := do + let state ← get + let nGoals := state.goalStates.size + set { state with nextId := 0, goalStates := .empty } + Lean.Core.resetMessageLog + return .ok { nGoals } + stat (_: Protocol.Stat): MainM (CR Protocol.StatResult) := do + let state ← get + let nGoals := state.goalStates.size + return .ok { nGoals } + env_catalog (args: Protocol.EnvCatalog): MainM (CR Protocol.EnvCatalogResult) := do + let result ← Environment.catalog args + return .ok result + env_inspect (args: Protocol.EnvInspect): MainM (CR Protocol.EnvInspectResult) := do + let state ← get + Environment.inspect args state.options + env_add (args: Protocol.EnvAdd): MainM (CR Protocol.EnvAddResult) := do + Environment.addDecl args + env_save (args: Protocol.EnvSaveLoad): MainM (CR Protocol.EnvSaveLoadResult) := do + let env ← Lean.MonadEnv.getEnv + environmentPickle env args.path + return .ok {} + env_load (args: Protocol.EnvSaveLoad): MainM (CR Protocol.EnvSaveLoadResult) := do + let (env, _) ← environmentUnpickle args.path + Lean.setEnv env + return .ok {} + expr_echo (args: Protocol.ExprEcho): MainM (CR Protocol.ExprEchoResult) := do + let state ← get + exprEcho args.expr (expectedType? := args.type?) (levels := args.levels.getD #[]) (options := state.options) + options_set (args: Protocol.OptionsSet): MainM (CR Protocol.OptionsSetResult) := do + let state ← get + let options := state.options + set { state with + options := { + -- FIXME: This should be replaced with something more elegant + printJsonPretty := args.printJsonPretty?.getD options.printJsonPretty, + printExprPretty := args.printExprPretty?.getD options.printExprPretty, + printExprAST := args.printExprAST?.getD options.printExprAST, + printDependentMVars := args.printDependentMVars?.getD options.printDependentMVars, + noRepeat := args.noRepeat?.getD options.noRepeat, + printAuxDecls := args.printAuxDecls?.getD options.printAuxDecls, + printImplementationDetailHyps := args.printImplementationDetailHyps?.getD options.printImplementationDetailHyps + automaticMode := args.automaticMode?.getD options.automaticMode, + } + } + return .ok { } + options_print (_: Protocol.OptionsPrint): MainM (CR Protocol.Options) := do + return .ok (← get).options + goal_start (args: Protocol.GoalStart): MainM (CR Protocol.GoalStartResult) := do + let env ← Lean.MonadEnv.getEnv + let expr?: Except _ GoalState ← runTermElabInMainM (match args.expr, args.copyFrom with + | .some expr, .none => goalStartExpr expr (args.levels.getD #[]) + | .none, .some copyFrom => + (match env.find? <| copyFrom.toName with + | .none => return .error <| errorIndex s!"Symbol not found: {copyFrom}" + | .some cInfo => return .ok (← GoalState.create cInfo.type)) + | _, _ => + return .error <| errorI "arguments" "Exactly one of {expr, copyFrom} must be supplied") + match expr? with + | .error error => return .error error + | .ok goalState => + let stateId ← newGoalState goalState + return .ok { stateId, root := goalState.root.name.toString } + goal_tactic (args: Protocol.GoalTactic): MainM (CR Protocol.GoalTacticResult) := do + let state ← get + let .some goalState := state.goalStates[args.stateId]? | + return .error $ errorIndex s!"Invalid state index {args.stateId}" + let .some goal := goalState.goals.get? args.goalId | + return .error $ errorIndex s!"Invalid goal index {args.goalId}" + let nextGoalState?: Except _ TacticResult ← runTermElabInMainM do + match args.tactic?, args.expr?, args.have?, args.let?, args.calc?, args.conv? with + | .some tactic, .none, .none, .none, .none, .none => do + pure <| Except.ok <| ← goalState.tryTactic goal tactic + | .none, .some expr, .none, .none, .none, .none => do + pure <| Except.ok <| ← goalState.tryAssign goal expr + | .none, .none, .some type, .none, .none, .none => do + let binderName := args.binderName?.getD "" + pure <| Except.ok <| ← goalState.tryHave goal binderName type + | .none, .none, .none, .some type, .none, .none => do + let binderName := args.binderName?.getD "" + pure <| Except.ok <| ← goalState.tryLet goal binderName type + | .none, .none, .none, .none, .some pred, .none => do + pure <| Except.ok <| ← goalState.tryCalc goal pred + | .none, .none, .none, .none, .none, .some true => do + pure <| Except.ok <| ← goalState.conv goal + | .none, .none, .none, .none, .none, .some false => do + pure <| Except.ok <| ← goalState.convExit + | _, _, _, _, _, _ => + let error := errorI "arguments" "Exactly one of {tactic, expr, have, calc, conv} must be supplied" + pure $ Except.error $ error + match nextGoalState? with + | .error error => return .error error + | .ok (.success nextGoalState) => do + let nextGoalState ← match state.options.automaticMode, args.conv? with + | true, .none => do + let .ok result := nextGoalState.resume (nextGoalState.goals ++ goalState.goals) | + throwError "Resuming known goals" + pure result + | true, .some true => pure nextGoalState + | true, .some false => do + let .some (_, _, dormantGoals) := goalState.convMVar? | + throwError "If conv exit succeeded this should not fail" + let .ok result := nextGoalState.resume (nextGoalState.goals ++ dormantGoals) | + throwError "Resuming known goals" + pure result + | false, _ => pure nextGoalState + let nextStateId ← newGoalState nextGoalState + let goals ← nextGoalState.serializeGoals (parent := .some goalState) (options := state.options) |>.run' + return .ok { + nextStateId? := .some nextStateId, + goals? := .some goals, + } + | .ok (.parseError message) => + return .ok { parseError? := .some message } + | .ok (.invalidAction message) => + return .error $ errorI "invalid" message + | .ok (.failure messages) => + return .ok { tacticErrors? := .some messages } + goal_continue (args: Protocol.GoalContinue): MainM (CR Protocol.GoalContinueResult) := do + let state ← get + let .some target := state.goalStates[args.target]? | + return .error $ errorIndex s!"Invalid state index {args.target}" + let nextState? ← match args.branch?, args.goals? with + | .some branchId, .none => do + match state.goalStates[branchId]? with + | .none => return .error $ errorIndex s!"Invalid state index {branchId}" + | .some branch => pure $ target.continue branch + | .none, .some goals => + pure $ goalResume target goals + | _, _ => return .error <| errorI "arguments" "Exactly one of {branch, goals} must be supplied" + match nextState? with + | .error error => return .error <| errorI "structure" error + | .ok nextGoalState => + let nextStateId ← newGoalState nextGoalState + let goals ← goalSerialize nextGoalState (options := state.options) + return .ok { + nextStateId, + goals, + } + goal_delete (args: Protocol.GoalDelete): MainM (CR Protocol.GoalDeleteResult) := do + let state ← get + let goalStates := args.stateIds.foldl (λ map id => map.erase id) state.goalStates + set { state with goalStates } + return .ok {} + goal_print (args: Protocol.GoalPrint): MainM (CR Protocol.GoalPrintResult) := do + let state ← get + let .some goalState := state.goalStates[args.stateId]? | + return .error $ errorIndex s!"Invalid state index {args.stateId}" + let result ← runMetaInMainM <| goalPrint + goalState + (rootExpr := args.rootExpr?.getD False) + (parentExpr := args.parentExpr?.getD False) + (goals := args.goals?.getD False) + (extraMVars := args.extraMVars?.getD #[]) + (options := state.options) + return .ok result + goal_save (args: Protocol.GoalSave): MainM (CR Protocol.GoalSaveResult) := do + let state ← get + let .some goalState := state.goalStates[args.id]? | + return .error $ errorIndex s!"Invalid state index {args.id}" + goalStatePickle goalState args.path + return .ok {} + goal_load (args: Protocol.GoalLoad): MainM (CR Protocol.GoalLoadResult) := do + let (goalState, _) ← goalStateUnpickle args.path (← Lean.MonadEnv.getEnv) + let id ← newGoalState goalState + return .ok { id } + frontend_process (args: Protocol.FrontendProcess): MainM (CR Protocol.FrontendProcessResult) := do + let options := (← get).options + try + let (fileName, file) ← match args.fileName?, args.file? with + | .some fileName, .none => do + let file ← IO.FS.readFile fileName + pure (fileName, file) + | .none, .some file => + pure ("", file) + | _, _ => return .error <| errorI "arguments" "Exactly one of {fileName, file} must be supplied" + let env?: Option Lean.Environment ← if args.fileName?.isSome then + pure .none + else do + let env ← Lean.MonadEnv.getEnv + pure <| .some env + let (context, state) ← do Frontend.createContextStateFromFile file fileName env? {} + let frontendM := Frontend.mapCompilationSteps λ step => do + let boundary := (step.src.startPos.byteIdx, step.src.stopPos.byteIdx) + let invocations?: Option (List Protocol.InvokedTactic) ← if args.invocations then + let invocations ← Frontend.collectTacticsFromCompilationStep step + pure $ .some invocations + else + pure .none + let sorrys ← if args.sorrys then + Frontend.collectSorrys step + else + pure [] + let messages ← step.messageStrings + let newConstants ← if args.newConstants then + Frontend.collectNewDefinedConstants step + else + pure [] + return (step.before, boundary, invocations?, sorrys, messages, newConstants) + let li ← frontendM.run context |>.run' state + let units ← li.mapM λ (env, boundary, invocations?, sorrys, messages, newConstants) => Lean.withEnv env do + let newConstants? := if args.newConstants then + .some $ newConstants.toArray.map λ name => name.toString + else + .none + let (goalStateId?, goals?, goalSrcBoundaries?) ← if sorrys.isEmpty then do + pure (.none, .none, .none) + else do + let { state, srcBoundaries } ← runMetaInMainM $ Frontend.sorrysToGoalState sorrys + let stateId ← newGoalState state + let goals ← goalSerialize state options + let srcBoundaries := srcBoundaries.toArray.map (λ (b, e) => (b.byteIdx, e.byteIdx)) + pure (.some stateId, .some goals, .some srcBoundaries) + return { + boundary, + messages, + invocations?, + goalStateId?, + goals?, + goalSrcBoundaries?, + newConstants?, + } + return .ok { units } + catch e => + return .error $ errorI "frontend" (← e.toMessageData.toString) + +end Pantograph.Repl diff --git a/Test/Common.lean b/Test/Common.lean new file mode 100644 index 0000000..53adaa0 --- /dev/null +++ b/Test/Common.lean @@ -0,0 +1,169 @@ +import Pantograph.Goal +import Pantograph.Library +import Pantograph.Protocol +import Lean +import LSpec + +open Lean + +namespace Pantograph + +deriving instance Repr for Expr +-- Use strict equality check for expressions +instance : BEq Expr := ⟨Expr.equal⟩ + +def uniq (n: Nat): Name := .num (.str .anonymous "_uniq") n + +-- Auxiliary functions +namespace Protocol +def Goal.devolatilizeVars (goal: Goal): Goal := + { + goal with + vars := goal.vars.map removeInternalAux, + + } + where removeInternalAux (v: Variable): Variable := + { + v with + name := "" + } +/-- Set internal names to "" -/ +def Goal.devolatilize (goal: Goal): Goal := + { + goal.devolatilizeVars with + name := "", + } + +deriving instance DecidableEq, Repr for Name +deriving instance DecidableEq, Repr for Expression +deriving instance DecidableEq, Repr for Variable +deriving instance DecidableEq, Repr for Goal +deriving instance DecidableEq, Repr for ExprEchoResult +deriving instance DecidableEq, Repr for InteractionError +deriving instance DecidableEq, Repr for Option +end Protocol + +namespace Condensed + +deriving instance BEq, Repr for LocalDecl +deriving instance BEq, Repr for Goal + +protected def LocalDecl.devolatilize (decl: LocalDecl): LocalDecl := + { + decl with fvarId := { name := .anonymous } + } +protected def Goal.devolatilize (goal: Goal): Goal := + { + goal with + mvarId := { name := .anonymous }, + context := goal.context.map LocalDecl.devolatilize + } + +end Condensed + +def GoalState.get! (state: GoalState) (i: Nat): MVarId := state.goals.get! i +def GoalState.tacticOn (state: GoalState) (goalId: Nat) (tactic: String) := state.tryTactic (state.goals.get! goalId) tactic + +def TacticResult.toString : TacticResult → String + | .success state => s!".success ({state.goals.length} goals)" + | .failure messages => + let messages := "\n".intercalate messages.toList + s!".failure {messages}" + | .parseError error => s!".parseError {error}" + | .invalidAction error => s!".invalidAction {error}" + +namespace Test + +def expectationFailure (desc: String) (error: String): LSpec.TestSeq := LSpec.test desc (LSpec.ExpectationFailure "ok _" error) +def assertUnreachable (message: String): LSpec.TestSeq := LSpec.check message false + +def parseFailure (error: String) := expectationFailure "parse" error +def elabFailure (error: String) := expectationFailure "elab" error + +def runCoreMSeq (env: Environment) (coreM: CoreM LSpec.TestSeq) (options: Array String := #[]): IO LSpec.TestSeq := do + let coreContext: Core.Context ← createCoreContext options + match ← (coreM.run' coreContext { env := env }).toBaseIO with + | .error exception => + return LSpec.test "Exception" (s!"internal exception #{← exception.toMessageData.toString}" = "") + | .ok a => return a +def runMetaMSeq (env: Environment) (metaM: MetaM LSpec.TestSeq): IO LSpec.TestSeq := + runCoreMSeq env metaM.run' +def runTermElabMInMeta { α } (termElabM: Lean.Elab.TermElabM α): Lean.MetaM α := + termElabM.run' (ctx := defaultElabContext) +def runTermElabMSeq (env: Environment) (termElabM: Elab.TermElabM LSpec.TestSeq): IO LSpec.TestSeq := + runMetaMSeq env $ termElabM.run' (ctx := defaultElabContext) + +def exprToStr (e: Expr): Lean.MetaM String := toString <$> Meta.ppExpr e + +def strToTermSyntax (s: String): CoreM Syntax := do + let .ok stx := Parser.runParserCategory + (env := ← MonadEnv.getEnv) + (catName := `term) + (input := s) + (fileName := ← getFileName) | panic! s!"Failed to parse {s}" + return stx +def parseSentence (s: String): Elab.TermElabM Expr := do + let stx ← match Parser.runParserCategory + (env := ← MonadEnv.getEnv) + (catName := `term) + (input := s) + (fileName := ← getFileName) with + | .ok syn => pure syn + | .error error => throwError "Failed to parse: {error}" + Elab.Term.elabTerm (stx := stx) .none + +def runTacticOnMVar (tacticM: Elab.Tactic.TacticM Unit) (goal: MVarId): Elab.TermElabM (List MVarId) := do + let (_, newGoals) ← tacticM { elaborator := .anonymous } |>.run { goals := [goal] } + return newGoals.goals +def mvarUserNameAndType (mvarId: MVarId): MetaM (Name × String) := do + let name := (← mvarId.getDecl).userName + let t ← exprToStr (← mvarId.getType) + return (name, t) + + +-- Monadic testing + +abbrev TestT := StateRefT' IO.RealWorld LSpec.TestSeq + +section Monadic + +variable [Monad m] [MonadLiftT (ST IO.RealWorld) m] + +def addTest (test: LSpec.TestSeq) : TestT m Unit := do + set $ (← get) ++ test + +def checkEq [DecidableEq α] [Repr α] (desc : String) (lhs rhs : α) : TestT m Unit := do + addTest $ LSpec.check desc (lhs = rhs) +def checkTrue (desc : String) (flag : Bool) : TestT m Unit := do + addTest $ LSpec.check desc flag +def fail (desc : String) : TestT m Unit := do + addTest $ LSpec.check desc false + +def runTest (t: TestT m Unit): m LSpec.TestSeq := + Prod.snd <$> t.run LSpec.TestSeq.done +def runTestWithResult { α } (t: TestT m α): m (α × LSpec.TestSeq) := + t.run LSpec.TestSeq.done + +end Monadic + +def runTestTermElabM (env: Environment) (t: TestT Elab.TermElabM Unit): + IO LSpec.TestSeq := + runTermElabMSeq env $ runTest t + +def cdeclOf (userName: Name) (type: Expr): Condensed.LocalDecl := + { userName, type } + +def buildGoal (nameType: List (String × String)) (target: String) (userName?: Option String := .none): + Protocol.Goal := + { + userName?, + target := { pp? := .some target}, + vars := (nameType.map fun x => ({ + userName := x.fst, + type? := .some { pp? := .some x.snd }, + })).toArray + } + +end Test + +end Pantograph diff --git a/Test/Delate.lean b/Test/Delate.lean new file mode 100644 index 0000000..d918dc8 --- /dev/null +++ b/Test/Delate.lean @@ -0,0 +1,109 @@ +import LSpec +import Pantograph.Delate +import Test.Common +import Lean + +open Lean +namespace Pantograph.Test.Delate + +open Pantograph + +deriving instance Repr, DecidableEq for Protocol.BoundExpression + +def test_serializeName: LSpec.TestSeq := + let quote := "\"" + let escape := "\\" + LSpec.test "a.b.1" (serializeName (Name.num (.str (.str .anonymous "a") "b") 1) = "a.b.1") ++ + LSpec.test "seg.«a.b»" (serializeName (Name.str (.str .anonymous "seg") "a.b") = s!"{quote}seg.«a.b»{quote}") ++ + -- Pathological test case + LSpec.test s!"«̈{escape}{quote}»" (serializeName (Name.str .anonymous s!"{escape}{quote}") = s!"{quote}«{escape}{quote}»{quote}") + +def test_expr_to_binder (env: Environment): IO LSpec.TestSeq := do + let entries: List (Name × Protocol.BoundExpression) := [ + ("Nat.add_comm".toName, { binders := #[("n", "Nat"), ("m", "Nat")], target := "n + m = m + n" }), + ("Nat.le_of_succ_le".toName, { binders := #[("n", "Nat"), ("m", "Nat"), ("h", "n.succ ≤ m")], target := "n ≤ m" }) + ] + runCoreMSeq env $ entries.foldlM (λ suites (symbol, target) => do + let env ← MonadEnv.getEnv + let expr := env.find? symbol |>.get! |>.type + let test := LSpec.check symbol.toString ((← typeExprToBound expr) = target) + return LSpec.TestSeq.append suites test) LSpec.TestSeq.done |>.run' + +def test_sexp_of_symbol (env: Environment): IO LSpec.TestSeq := do + let entries: List (String × String) := [ + -- This one contains unhygienic variable names which must be suppressed + ("Nat.add", "(:forall a (:c Nat) (:forall a (:c Nat) (:c Nat)))"), + -- These ones are normal and easy + ("Nat.add_one", "(:forall n (:c Nat) ((:c Eq) (:c Nat) ((:c HAdd.hAdd) (:c Nat) (:c Nat) (:c Nat) ((:c instHAdd) (:c Nat) (:c instAddNat)) 0 ((:c OfNat.ofNat) (:c Nat) (:lit 1) ((:c instOfNatNat) (:lit 1)))) ((:c Nat.succ) 0)))"), + ("Nat.le_of_succ_le", "(:forall n (:c Nat) (:forall m (:c Nat) (:forall h ((:c LE.le) (:c Nat) (:c instLENat) ((:c Nat.succ) 1) 0) ((:c LE.le) (:c Nat) (:c instLENat) 2 1)) :implicit) :implicit)"), + -- Handling of higher order types + ("Or", "(:forall a (:sort 0) (:forall b (:sort 0) (:sort 0)))"), + ("List", "(:forall α (:sort (+ u 1)) (:sort (+ u 1)))") + ] + runMetaMSeq env $ entries.foldlM (λ suites (symbol, target) => do + let env ← MonadEnv.getEnv + let expr := env.find? symbol.toName |>.get! |>.type + let test := LSpec.check symbol ((← serializeExpressionSexp expr) = target) + return LSpec.TestSeq.append suites test) LSpec.TestSeq.done + +def test_sexp_of_elab (env: Environment): IO LSpec.TestSeq := do + let entries: List (String × (List Name) × String) := [ + ("λ x: Nat × Bool => x.1", [], "(:lambda x ((:c Prod) (:c Nat) (:c Bool)) ((:c Prod.fst) (:c Nat) (:c Bool) 0))"), + ("λ x: Array Nat => x.data", [], "(:lambda x ((:c Array) (:c Nat)) ((:c Array.data) (:c Nat) 0))"), + ("λ {α: Sort (u + 1)} => List α", [`u], "(:lambda α (:sort (+ u 1)) ((:c List) 0) :implicit)"), + ("λ {α} => List α", [], "(:lambda α (:sort (+ (:mv _uniq.4) 1)) ((:c List) 0) :implicit)"), + ("(2: Nat) <= (5: Nat)", [], "((:c LE.le) (:mv _uniq.18) (:mv _uniq.19) ((:c OfNat.ofNat) (:mv _uniq.4) (:lit 2) (:mv _uniq.5)) ((:c OfNat.ofNat) (:mv _uniq.14) (:lit 5) (:mv _uniq.15)))"), + ] + entries.foldlM (λ suites (source, levels, target) => + let termElabM := do + let env ← MonadEnv.getEnv + let s ← match parseTerm env source with + | .ok s => pure s + | .error e => return parseFailure e + let expr ← match (← elabTerm s) with + | .ok expr => pure expr + | .error e => return elabFailure e + return LSpec.check source ((← serializeExpressionSexp expr) = target) + let metaM := (Elab.Term.withLevelNames levels termElabM).run' (ctx := defaultElabContext) + return LSpec.TestSeq.append suites (← runMetaMSeq env metaM)) + LSpec.TestSeq.done + +def test_sexp_of_expr (env: Environment): IO LSpec.TestSeq := do + let entries: List (Expr × String) := [ + (.lam `p (.sort .zero) + (.lam `q (.sort .zero) + (.lam `k (mkApp2 (.const `And []) (.bvar 1) (.bvar 0)) + (.proj `And 1 (.bvar 0)) + .default) + .implicit) + .implicit, + "(:lambda p (:sort 0) (:lambda q (:sort 0) (:lambda k ((:c And) 1 0) ((:c And.right) _ _ 0)) :implicit) :implicit)" + ), + ] + let termElabM: Elab.TermElabM LSpec.TestSeq := entries.foldlM (λ suites (expr, target) => do + let env ← MonadEnv.getEnv + let testCaseName := target.take 10 + let test := LSpec.check testCaseName ((← serializeExpressionSexp expr) = target) + return LSpec.TestSeq.append suites test) LSpec.TestSeq.done + runMetaMSeq env $ termElabM.run' (ctx := defaultElabContext) + +-- Instance parsing +def test_instance (env: Environment): IO LSpec.TestSeq := + runMetaMSeq env do + let env ← MonadEnv.getEnv + let source := "λ x y: Nat => HAdd.hAdd Nat Nat Nat (instHAdd Nat instAddNat) x y" + let s := parseTerm env source |>.toOption |>.get! + let _expr := (← runTermElabMInMeta <| elabTerm s) |>.toOption |>.get! + return LSpec.TestSeq.done + +def suite (env: Environment): List (String × IO LSpec.TestSeq) := + [ + ("serializeName", do pure test_serializeName), + ("Expression binder", test_expr_to_binder env), + ("Sexp from symbol", test_sexp_of_symbol env), + ("Sexp from elaborated expr", test_sexp_of_elab env), + ("Sexp from expr", test_sexp_of_expr env), + ("Instance", test_instance env), + ] + +end Pantograph.Test.Delate diff --git a/Test/Environment.lean b/Test/Environment.lean new file mode 100644 index 0000000..79d04ed --- /dev/null +++ b/Test/Environment.lean @@ -0,0 +1,107 @@ +import LSpec +import Pantograph.Delate +import Pantograph.Environment +import Test.Common +import Lean + +open Lean +namespace Pantograph.Test.Environment + +open Pantograph + +deriving instance DecidableEq, Repr for Protocol.InductInfo +deriving instance DecidableEq, Repr for Protocol.ConstructorInfo +deriving instance DecidableEq, Repr for Protocol.RecursorRule +deriving instance DecidableEq, Repr for Protocol.RecursorInfo +deriving instance DecidableEq, Repr for Protocol.EnvInspectResult + +def test_catalog: IO LSpec.TestSeq := do + let env: Environment ← importModules + (imports := #[`Init]) + (opts := {}) + (trustLevel := 1) + let inner: CoreM LSpec.TestSeq := do + let catalogResult ← Environment.catalog {} + let symbolsWithNum := env.constants.fold (init := #[]) (λ acc name info => + match (Environment.toFilteredSymbol name info).isSome && (name matches .num _ _) with + | false => acc + | true => acc.push name + ) + return LSpec.check "No num symbols" (symbolsWithNum.size == 0) + runCoreMSeq env inner + +def test_symbol_visibility: IO LSpec.TestSeq := do + let entries: List (Name × Bool) := [ + ("Nat.add_comm".toName, false), + ("foo.bla.Init.Data.List.Basic.2.1.Init.Lean.Expr._hyg.4".toName, true), + ("Init.Data.Nat.Basic._auxLemma.4".toName, true), + ] + let suite := entries.foldl (λ suites (symbol, target) => + let test := LSpec.check symbol.toString ((Environment.isNameInternal symbol) == target) + LSpec.TestSeq.append suites test) LSpec.TestSeq.done + return suite + +inductive ConstantCat where + | induct (info: Protocol.InductInfo) + | ctor (info: Protocol.ConstructorInfo) + | recursor (info: Protocol.RecursorInfo) + +def test_inspect: IO LSpec.TestSeq := do + let env: Environment ← importModules + (imports := #[`Init]) + (opts := {}) + (trustLevel := 1) + let testCases: List (String × ConstantCat) := [ + ("Or", ConstantCat.induct { + numParams := 2, + numIndices := 0, + all := #["Or"], + ctors := #["Or.inl", "Or.inr"], + }), + ("Except.ok", ConstantCat.ctor { + induct := "Except", + cidx := 1, + numParams := 2, + numFields := 1, + }), + ("Eq.rec", ConstantCat.recursor { + all := #["Eq"], + numParams := 2, + numIndices := 1, + numMotives := 1, + numMinors := 1, + rules := #[{ ctor := "Eq.refl", nFields := 0, rhs := { pp? := .some "fun {α} a motive refl => refl" } }] + k := true, + }), + ("ForM.rec", ConstantCat.recursor { + all := #["ForM"], + numParams := 3, + numIndices := 0, + numMotives := 1, + numMinors := 1, + rules := #[{ ctor := "ForM.mk", nFields := 1, rhs := { pp? := .some "fun m γ α motive mk forM => mk forM" } }] + k := false, + }) + ] + let inner: CoreM LSpec.TestSeq := do + testCases.foldlM (λ acc (name, cat) => do + let args: Protocol.EnvInspect := { name := name } + let result ← match ← Environment.inspect args (options := {}) with + | .ok result => pure $ result + | .error e => panic! s!"Error: {e.desc}" + let p := match cat with + | .induct info => LSpec.test name (result.inductInfo? == .some info) + | .ctor info => LSpec.test name (result.constructorInfo? == .some info) + | .recursor info => LSpec.test name (result.recursorInfo? == .some info) + return LSpec.TestSeq.append acc p + ) LSpec.TestSeq.done + runCoreMSeq env inner + +def suite: List (String × IO LSpec.TestSeq) := + [ + ("Catalog", test_catalog), + ("Symbol Visibility", test_symbol_visibility), + ("Inspect", test_inspect), + ] + +end Pantograph.Test.Environment diff --git a/Test/Frontend.lean b/Test/Frontend.lean new file mode 100644 index 0000000..a3b73ae --- /dev/null +++ b/Test/Frontend.lean @@ -0,0 +1,235 @@ +import LSpec +import Pantograph +import Repl +import Test.Common + +open Lean Pantograph +namespace Pantograph.Test.Frontend + +def collectSorrysFromSource (source: String) : MetaM (List GoalState) := do + let filename := "" + let (context, state) ← do Frontend.createContextStateFromFile source filename (← getEnv) {} + let m := Frontend.mapCompilationSteps λ step => do + return (step.before, ← Frontend.collectSorrys step) + let li ← m.run context |>.run' state + let goalStates ← li.filterMapM λ (env, sorrys) => withEnv env do + if sorrys.isEmpty then + return .none + let { state, .. } ← Frontend.sorrysToGoalState sorrys + return .some state + return goalStates + +def test_multiple_sorrys_in_proof : TestT MetaM Unit := do + let sketch := " +theorem plus_n_Sm_proved_formal_sketch : ∀ n m : Nat, n + (m + 1) = (n + m) + 1 := by + have h_nat_add_succ: ∀ n m : Nat, n = m := sorry + sorry + " + let goalStates ← (collectSorrysFromSource sketch).run' {} + let [goalState] := goalStates | panic! "Incorrect number of states" + addTest $ LSpec.check "goals" ((← goalState.serializeGoals (options := {})).map (·.devolatilize) = #[ + { + target := { pp? := "∀ (n m : Nat), n = m" }, + vars := #[ + ] + }, + { + target := { pp? := "∀ (n m : Nat), n + (m + 1) = n + m + 1" }, + vars := #[{ + userName := "h_nat_add_succ", + type? := .some { pp? := "∀ (n m : Nat), n = m" }, + }], + } + ]) + +def test_sorry_in_middle: TestT MetaM Unit := do + let sketch := " +example : ∀ (n m: Nat), n + m = m + n := by + intros n m + sorry + " + let goalStates ← (collectSorrysFromSource sketch).run' {} + let [goalState] := goalStates | panic! s!"Incorrect number of states: {goalStates.length}" + addTest $ LSpec.check "goals" ((← goalState.serializeGoals (options := {})).map (·.devolatilize) = #[ + { + target := { pp? := "n + m = m + n" }, + vars := #[{ + userName := "n", + type? := .some { pp? := "Nat" }, + }, { + userName := "m", + type? := .some { pp? := "Nat" }, + } + ], + } + ]) + +def test_sorry_in_induction : TestT MetaM Unit := do + let sketch := " +example : ∀ (n m: Nat), n + m = m + n := by + intros n m + induction n with + | zero => + have h1 : 0 + m = m := sorry + sorry + | succ n ih => + have h2 : n + m = m := sorry + sorry + " + let goalStates ← (collectSorrysFromSource sketch).run' {} + let [goalState] := goalStates | panic! s!"Incorrect number of states: {goalStates.length}" + addTest $ LSpec.check "goals" ((← goalState.serializeGoals (options := {})).map (·.devolatilize) = #[ + { + target := { pp? := "0 + m = m" }, + vars := #[{ + userName := "m", + type? := .some { pp? := "Nat" }, + }] + }, + { + userName? := .some "zero", + target := { pp? := "0 + m = m + 0" }, + vars := #[{ + userName := "m", + type? := .some { pp? := "Nat" }, + }, { + userName := "h1", + type? := .some { pp? := "0 + m = m" }, + }] + }, + { + target := { pp? := "n + m = m" }, + vars := #[{ + userName := "m", + type? := .some { pp? := "Nat" }, + }, { + userName := "n", + type? := .some { pp? := "Nat" }, + }, { + userName := "ih", + type? := .some { pp? := "n + m = m + n" }, + }] + }, + { + userName? := .some "succ", + target := { pp? := "n + 1 + m = m + (n + 1)" }, + vars := #[{ + userName := "m", + type? := .some { pp? := "Nat" }, + }, { + userName := "n", + type? := .some { pp? := "Nat" }, + }, { + userName := "ih", + type? := .some { pp? := "n + m = m + n" }, + }, { + userName := "h2", + type? := .some { pp? := "n + m = m" }, + }] + } + ]) + +def test_sorry_in_coupled: TestT MetaM Unit := do + let sketch := " +example : ∀ (y: Nat), ∃ (x: Nat), y + 1 = x := by + intro y + apply Exists.intro + case h => sorry + case w => sorry + " + let goalStates ← (collectSorrysFromSource sketch).run' {} + let [goalState] := goalStates | panic! s!"Incorrect number of states: {goalStates.length}" + addTest $ LSpec.check "goals" ((← goalState.serializeGoals (options := {})).map (·.devolatilize) = #[ + { + target := { pp? := "y + 1 = ?w" }, + vars := #[{ + userName := "y", + type? := .some { pp? := "Nat" }, + } + ], + }, + { + userName? := .some "w", + target := { pp? := "Nat" }, + vars := #[{ + userName := "y", + type? := .some { pp? := "Nat" }, + } + ], + } + ]) + +def test_environment_capture: TestT MetaM Unit := do + let sketch := " +def mystery (n: Nat) := n + 1 + +example (n: Nat) : mystery n + 1 = n + 2 := sorry + " + let goalStates ← (collectSorrysFromSource sketch).run' {} + let [goalState] := goalStates | panic! s!"Incorrect number of states: {goalStates.length}" + addTest $ LSpec.check "goals" ((← goalState.serializeGoals (options := {})).map (·.devolatilize) = #[ + { + target := { pp? := "mystery n + 1 = n + 2" }, + vars := #[{ + userName := "n", + type? := .some { pp? := "Nat" }, + }], + } + ]) + +def test_capture_type_mismatch : TestT MetaM Unit := do + let input := " +def mystery (k: Nat) : Nat := true + " + let goalStates ← (collectSorrysFromSource input).run' {} + let [goalState] := goalStates | panic! s!"Incorrect number of states: {goalStates.length}" + checkEq "goals" ((← goalState.serializeGoals (options := {})).map (·.devolatilize)) #[ + { + target := { pp? := "Nat" }, + vars := #[{ + userName := "k", + type? := .some { pp? := "Nat" }, + }], + } + ] + +def collectNewConstants (source: String) : MetaM (List (List Name)) := do + let filename := "" + let (context, state) ← do Frontend.createContextStateFromFile source filename (← getEnv) {} + let m := Frontend.mapCompilationSteps λ step => do + Frontend.collectNewDefinedConstants step + m.run context |>.run' state + +def test_collect_one_constant : TestT MetaM Unit := do + let input := " +def mystery : Nat := 123 + " + let names ← collectNewConstants input + checkEq "constants" names [[`mystery]] +def test_collect_one_theorem : TestT MetaM Unit := do + let input := " +theorem mystery [SizeOf α] (as : List α) (i : Fin as.length) : sizeOf (as.get i) < sizeOf as := by + match as, i with + | a::as, ⟨0, _⟩ => simp_arith [get] + | a::as, ⟨i+1, h⟩ => + have ih := sizeOf_get as ⟨i, Nat.le_of_succ_le_succ h⟩ + apply Nat.lt_trans ih + simp_arith + " + let names ← collectNewConstants input + checkEq "constants" names [[`mystery]] + +def suite (env : Environment): List (String × IO LSpec.TestSeq) := + let tests := [ + ("multiple_sorrys_in_proof", test_multiple_sorrys_in_proof), + ("sorry_in_middle", test_sorry_in_middle), + ("sorry_in_induction", test_sorry_in_induction), + ("sorry_in_coupled", test_sorry_in_coupled), + ("environment_capture", test_environment_capture), + ("capture_type_mismatch", test_capture_type_mismatch), + ("collect_one_constant", test_collect_one_constant), + ("collect_one_theorem", test_collect_one_theorem), + ] + tests.map (fun (name, test) => (name, runMetaMSeq env $ runTest test)) + +end Pantograph.Test.Frontend diff --git a/Test/Integration.lean b/Test/Integration.lean new file mode 100644 index 0000000..77968f0 --- /dev/null +++ b/Test/Integration.lean @@ -0,0 +1,261 @@ +/- Integration test for the REPL + -/ +import LSpec +import Pantograph +import Repl +import Test.Common + +namespace Pantograph.Test.Integration +open Pantograph.Repl + +def step { α } [Lean.ToJson α] (cmd: String) (payload: List (String × Lean.Json)) + (expected: α) (name? : Option String := .none): MainM LSpec.TestSeq := do + let payload := Lean.Json.mkObj payload + let name := name?.getD s!"{cmd} {payload.compress}" + let result ← Repl.execute { cmd, payload } + return LSpec.test name (toString result = toString (Lean.toJson expected)) + +abbrev Test := List (MainM LSpec.TestSeq) + +def test_elab : Test := + [ + step "expr.echo" + [("expr", .str "λ {α : Sort (u + 1)} => List α"), ("levels", .arr #["u"])] + (Lean.toJson ({ + type := { pp? := .some "{α : Type u} → Type u" }, + expr := { pp? := .some "fun {α} => List α" } + }: Protocol.ExprEchoResult)), + ] + +def test_option_modify : Test := + let pp? := Option.some "∀ (n : Nat), n + 1 = n.succ" + let sexp? := Option.some "(:forall n (:c Nat) ((:c Eq) (:c Nat) ((:c HAdd.hAdd) (:c Nat) (:c Nat) (:c Nat) ((:c instHAdd) (:c Nat) (:c instAddNat)) 0 ((:c OfNat.ofNat) (:c Nat) (:lit 1) ((:c instOfNatNat) (:lit 1)))) ((:c Nat.succ) 0)))" + let module? := Option.some "Init.Data.Nat.Basic" + let options: Protocol.Options := {} + [ + step "env.inspect" [("name", .str "Nat.add_one")] + ({ type := { pp? }, module? }: Protocol.EnvInspectResult), + step "options.set" [("printExprAST", .bool true)] + ({ }: Protocol.OptionsSetResult), + step "env.inspect" [("name", .str "Nat.add_one")] + ({ type := { pp?, sexp? }, module? }: Protocol.EnvInspectResult), + step "options.print" [] + ({ options with printExprAST := true }: Protocol.Options), + ] +def test_malformed_command : Test := + let invalid := "invalid" + [ + step invalid [("name", .str "Nat.add_one")] + ({ error := "command", desc := s!"Unknown command {invalid}" }: Protocol.InteractionError) + (name? := .some "Invalid Command"), + step "expr.echo" [(invalid, .str "Random garbage data")] + ({ error := "command", desc := s!"Unable to parse json: Pantograph.Protocol.ExprEcho.expr: String expected" }: + Protocol.InteractionError) + (name? := .some "JSON Deserialization") + ] +def test_tactic : Test := + let goal1: Protocol.Goal := { + name := "_uniq.11", + target := { pp? := .some "∀ (q : Prop), x ∨ q → q ∨ x" }, + vars := #[{ name := "_uniq.10", userName := "x", type? := .some { pp? := .some "Prop" }}], + } + let goal2: Protocol.Goal := { + name := "_uniq.17", + target := { pp? := .some "x ∨ y → y ∨ x" }, + vars := #[ + { name := "_uniq.10", userName := "x", type? := .some { pp? := .some "Prop" }}, + { name := "_uniq.16", userName := "y", type? := .some { pp? := .some "Prop" }} + ], + } + [ + step "goal.start" [("expr", .str "∀ (p q: Prop), p ∨ q → q ∨ p")] + ({ stateId := 0, root := "_uniq.9" }: Protocol.GoalStartResult), + step "goal.tactic" [("stateId", .num 0), ("goalId", .num 0), ("tactic", .str "intro x")] + ({ nextStateId? := .some 1, goals? := #[goal1], }: Protocol.GoalTacticResult), + step "goal.print" [("stateId", .num 1), ("parentExpr", .bool true), ("rootExpr", .bool true)] + ({ parent? := .some { pp? := .some "fun x => ?m.12 x" }, }: Protocol.GoalPrintResult), + step "goal.tactic" [("stateId", .num 1), ("goalId", .num 0), ("tactic", .str "intro y")] + ({ nextStateId? := .some 2, goals? := #[goal2], }: Protocol.GoalTacticResult), + ] +def test_automatic_mode (automatic: Bool): Test := + let varsPQ := #[ + { name := "_uniq.10", userName := "p", type? := .some { pp? := .some "Prop" }}, + { name := "_uniq.13", userName := "q", type? := .some { pp? := .some "Prop" }} + ] + let goal1: Protocol.Goal := { + name := "_uniq.17", + target := { pp? := .some "q ∨ p" }, + vars := varsPQ ++ #[ + { name := "_uniq.16", userName := "h", type? := .some { pp? := .some "p ∨ q" }} + ], + } + let goal2l: Protocol.Goal := { + name := "_uniq.59", + userName? := .some "inl", + target := { pp? := .some "q ∨ p" }, + vars := varsPQ ++ #[ + { name := "_uniq.47", userName := "h✝", type? := .some { pp? := .some "p" }, isInaccessible := true} + ], + } + let goal2r: Protocol.Goal := { + name := "_uniq.72", + userName? := .some "inr", + target := { pp? := .some "q ∨ p" }, + vars := varsPQ ++ #[ + { name := "_uniq.60", userName := "h✝", type? := .some { pp? := .some "q" }, isInaccessible := true} + ], + } + let goal3l: Protocol.Goal := { + name := "_uniq.78", + userName? := .some "inl.h", + target := { pp? := .some "p" }, + vars := varsPQ ++ #[ + { name := "_uniq.47", userName := "h✝", type? := .some { pp? := .some "p" }, isInaccessible := true} + ], + } + [ + step "options.set" [("automaticMode", .bool automatic)] + ({}: Protocol.OptionsSetResult), + step "goal.start" [("expr", .str "∀ (p q: Prop), p ∨ q → q ∨ p")] + ({ stateId := 0, root := "_uniq.9" }: Protocol.GoalStartResult), + step "goal.tactic" [("stateId", .num 0), ("goalId", .num 0), ("tactic", .str "intro p q h")] + ({ nextStateId? := .some 1, goals? := #[goal1], }: Protocol.GoalTacticResult), + step "goal.tactic" [("stateId", .num 1), ("goalId", .num 0), ("tactic", .str "cases h")] + ({ nextStateId? := .some 2, goals? := #[goal2l, goal2r], }: Protocol.GoalTacticResult), + let goals? := if automatic then #[goal3l, goal2r] else #[goal3l] + step "goal.tactic" [("stateId", .num 2), ("goalId", .num 0), ("tactic", .str "apply Or.inr")] + ({ nextStateId? := .some 3, goals?, }: Protocol.GoalTacticResult), + ] + +def test_env_add_inspect : Test := + let name1 := "Pantograph.mystery" + let name2 := "Pantograph.mystery2" + [ + step "env.add" + [ + ("name", .str name1), + ("type", .str "Prop → Prop → Prop"), + ("value", .str "λ (a b: Prop) => Or a b"), + ("isTheorem", .bool false) + ] + ({}: Protocol.EnvAddResult), + step "env.inspect" [("name", .str name1)] + ({ + value? := .some { pp? := .some "fun a b => a ∨ b" }, + type := { pp? := .some "Prop → Prop → Prop" }, + }: + Protocol.EnvInspectResult), + step "env.add" + [ + ("name", .str name2), + ("type", .str "Nat → Int"), + ("value", .str "λ (a: Nat) => a + 1"), + ("isTheorem", .bool false) + ] + ({}: Protocol.EnvAddResult), + step "env.inspect" [("name", .str name2)] + ({ + value? := .some { pp? := .some "fun a => ↑a + 1" }, + type := { pp? := .some "Nat → Int" }, + }: + Protocol.EnvInspectResult) + ] + +example : ∀ (p: Prop), p → p := by + intro p h + exact h + +def test_frontend_process : Test := + [ + let file := "example : ∀ (p q: Prop), p → p ∨ q := by\n intro p q h\n exact Or.inl h" + let goal1 := "p q : Prop\nh : p\n⊢ p ∨ q" + step "frontend.process" + [ + ("file", .str file), + ("invocations", .bool true), + ("sorrys", .bool false), + ("newConstants", .bool false), + ] + ({ + units := [{ + boundary := (0, file.utf8ByteSize), + invocations? := .some [ + { + goalBefore := "⊢ ∀ (p q : Prop), p → p ∨ q", + goalAfter := goal1, + tactic := "intro p q h", + usedConstants := #[], + }, + { + goalBefore := goal1 , + goalAfter := "", + tactic := "exact Or.inl h", + usedConstants := #["Or.inl"], + }, + ] + }], + }: Protocol.FrontendProcessResult), + ] + +example : 1 + 2 = 3 := rfl +example (p: Prop): p → p := by simp + +def test_frontend_process_sorry : Test := + let solved := "example : 1 + 2 = 3 := rfl\n" + let withSorry := "example (p: Prop): p → p := sorry" + [ + let file := s!"{solved}{withSorry}" + let goal1: Protocol.Goal := { + name := "_uniq.6", + target := { pp? := .some "p → p" }, + vars := #[{ name := "_uniq.4", userName := "p", type? := .some { pp? := .some "Prop" }}], + } + step "frontend.process" + [ + ("file", .str file), + ("invocations", .bool false), + ("sorrys", .bool true), + ("newConstants", .bool false), + ] + ({ + units := [{ + boundary := (0, solved.utf8ByteSize), + }, { + boundary := (solved.utf8ByteSize, solved.utf8ByteSize + withSorry.utf8ByteSize), + goalStateId? := .some 0, + goals? := .some #[goal1], + goalSrcBoundaries? := .some #[(57, 62)], + messages := #[":2:0: warning: declaration uses 'sorry'\n"], + }], + }: Protocol.FrontendProcessResult), + ] + + +def runTest (env: Lean.Environment) (steps: Test): IO LSpec.TestSeq := do + -- Setup the environment for execution + let context: Context := { + imports := ["Init"] + } + let commands: MainM LSpec.TestSeq := + steps.foldlM (λ suite step => do + let result ← step + return suite ++ result) LSpec.TestSeq.done + runCoreMSeq env <| commands.run context |>.run' {} + + +def suite (env : Lean.Environment): List (String × IO LSpec.TestSeq) := + let tests := [ + ("expr.echo", test_elab), + ("options.set options.print", test_option_modify), + ("Malformed command", test_malformed_command), + ("Tactic", test_tactic), + ("Manual Mode", test_automatic_mode false), + ("Automatic Mode", test_automatic_mode true), + ("env.add env.inspect", test_env_add_inspect), + ("frontend.process invocation", test_frontend_process), + ("frontend.process sorry", test_frontend_process_sorry), + ] + tests.map (fun (name, test) => (name, runTest env test)) + + +end Pantograph.Test.Integration diff --git a/Test/Library.lean b/Test/Library.lean new file mode 100644 index 0000000..df1ba4d --- /dev/null +++ b/Test/Library.lean @@ -0,0 +1,38 @@ +import LSpec +import Lean +import Pantograph.Library +import Test.Common + +open Lean +open Pantograph + +namespace Pantograph.Test.Library + +def test_expr_echo (env: Environment): IO LSpec.TestSeq := do + let inner: CoreM LSpec.TestSeq := do + let prop_and_proof := "⟨∀ (x: Prop), x → x, λ (x: Prop) (h: x) => h⟩" + let tests := LSpec.TestSeq.done + let echoResult ← exprEcho prop_and_proof (options := {}) + let tests := tests.append (LSpec.test "fail" (echoResult.toOption == .some { + type := { pp? := "?m.2" }, expr := { pp? := "?m.3" } + })) + let echoResult ← exprEcho prop_and_proof (expectedType? := .some "Σ' p:Prop, p") (options := { printExprAST := true }) + let tests := tests.append (LSpec.test "fail" (echoResult.toOption == .some { + type := { + pp? := "(p : Prop) ×' p", + sexp? := "((:c PSigma) (:sort 0) (:lambda p (:sort 0) 0))", + }, + expr := { + pp? := "⟨∀ (x : Prop), x → x, fun x h => h⟩", + sexp? := "((:c PSigma.mk) (:sort 0) (:lambda p (:sort 0) 0) (:forall x (:sort 0) (:forall a 0 1)) (:lambda x (:sort 0) (:lambda h 0 0)))", + } + })) + return tests + runCoreMSeq env (options := #["pp.proofs.threshold=100"]) inner + +def suite (env: Environment): List (String × IO LSpec.TestSeq) := + [ + ("expr_echo", test_expr_echo env), + ] + +end Pantograph.Test.Library diff --git a/Test/Main.lean b/Test/Main.lean index 22d8984..6bf410e 100644 --- a/Test/Main.lean +++ b/Test/Main.lean @@ -1,17 +1,62 @@ import LSpec -import Pantograph.Symbols +import Test.Delate +import Test.Environment +import Test.Frontend +import Test.Integration +import Test.Library +import Test.Metavar import Test.Proofs import Test.Serial +import Test.Tactic + +-- Test running infrastructure + +namespace Pantograph.Test + +def addPrefix (pref: String) (tests: List (String × α)): List (String × α) := + tests.map (λ (name, x) => (pref ++ "/" ++ name, x)) + +/-- Runs test in parallel. Filters test name if given -/ +def runTestGroup (filter: Option String) (tests: List (String × IO LSpec.TestSeq)): IO LSpec.TestSeq := do + let tests: List (String × IO LSpec.TestSeq) := match filter with + | .some filter => tests.filter (λ (name, _) => filter.isPrefixOf name) + | .none => tests + let tasks: List (String × Task _) ← tests.mapM (λ (name, task) => do + return (name, ← EIO.asTask task)) + let all := tasks.foldl (λ acc (name, task) => + let v: Except IO.Error LSpec.TestSeq := Task.get task + match v with + | .ok case => acc ++ (LSpec.group name case) + | .error e => acc ++ (expectationFailure name e.toString) + ) LSpec.TestSeq.done + return all + +end Pantograph.Test open Pantograph.Test -unsafe def main := do - Lean.enableInitializersExecution +/-- Main entry of tests; Provide an argument to filter tests by prefix -/ +def main (args: List String) := do + let name_filter := args.head? Lean.initSearchPath (← Lean.findSysroot) + let env_default: Lean.Environment ← Lean.importModules + (imports := #[`Init]) + (opts := {}) + (trustLevel := 1) - let suites := [ - test_serial, - test_proofs + let suites: List (String × List (String × IO LSpec.TestSeq)) := [ + ("Environment", Environment.suite), + ("Frontend", Frontend.suite env_default), + ("Integration", Integration.suite env_default), + ("Library", Library.suite env_default), + ("Metavar", Metavar.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/Motivated Apply", Tactic.MotivatedApply.suite env_default), + ("Tactic/No Confuse", Tactic.NoConfuse.suite env_default), + ("Tactic/Prograde", Tactic.Prograde.suite env_default), ] - let all ← suites.foldlM (λ acc m => do pure $ acc ++ (← m)) LSpec.TestSeq.done - LSpec.lspecIO $ all + let tests: List (String × IO LSpec.TestSeq) := suites.foldl (λ acc (name, suite) => acc ++ (addPrefix name suite)) [] + LSpec.lspecIO (← runTestGroup name_filter tests) diff --git a/Test/Metavar.lean b/Test/Metavar.lean new file mode 100644 index 0000000..c6fc4f0 --- /dev/null +++ b/Test/Metavar.lean @@ -0,0 +1,280 @@ +import LSpec +import Pantograph.Goal +import Pantograph.Delate +import Test.Common +import Lean + +namespace Pantograph.Test.Metavar +open Pantograph +open Lean + +abbrev TestM := TestT $ ReaderT Protocol.Options Elab.TermElabM + +-- Tests that all delay assigned mvars are instantiated +def test_instantiate_mvar: TestM Unit := do + let env ← Lean.MonadEnv.getEnv + let value := "@Nat.le_trans 2 2 5 (@of_eq_true (@LE.le Nat instLENat 2 2) (@eq_true (@LE.le Nat instLENat 2 2) (@Nat.le_refl 2))) (@of_eq_true (@LE.le Nat instLENat 2 5) (@eq_true_of_decide (@LE.le Nat instLENat 2 5) (@Nat.decLe 2 5) (@Eq.refl Bool Bool.true)))" + let syn ← match parseTerm env value with + | .ok s => pure $ s + | .error e => do + addTest $ assertUnreachable e + return () + let expr ← match ← elabTerm syn with + | .ok expr => pure $ expr + | .error e => do + addTest $ assertUnreachable e + return () + let t ← Lean.Meta.inferType expr + addTest $ LSpec.check "typing" ((toString (← serializeExpressionSexp t)) = + "((:c LE.le) (:c Nat) (:c instLENat) ((:c OfNat.ofNat) (:mv _uniq.2) (:lit 2) (:mv _uniq.3)) ((:c OfNat.ofNat) (:mv _uniq.14) (:lit 5) (:mv _uniq.15)))") + return () + +def startProof (expr: String): TestM (Option GoalState) := do + let env ← Lean.MonadEnv.getEnv + let syn? := parseTerm env expr + addTest $ LSpec.check s!"Parsing {expr}" (syn?.isOk) + match syn? with + | .error error => + IO.println error + return Option.none + | .ok syn => + let expr? ← elabType syn + addTest $ LSpec.check s!"Elaborating" expr?.isOk + match expr? with + | .error error => + IO.println error + return Option.none + | .ok expr => + let goal ← GoalState.create (expr := expr) + return Option.some goal + +def buildGoal (nameType: List (String × String)) (target: String) (userName?: Option String := .none): Protocol.Goal := + { + userName?, + target := { pp? := .some target}, + vars := (nameType.map fun x => ({ + userName := x.fst, + type? := .some { pp? := .some x.snd }, + })).toArray + } +def proofRunner (env: Lean.Environment) (tests: TestM Unit): IO LSpec.TestSeq := do + let termElabM := tests.run LSpec.TestSeq.done |>.run {} -- with default options + + let coreContext: Lean.Core.Context ← createCoreContext #[] + let metaM := termElabM.run' (ctx := defaultElabContext) + let coreM := metaM.run' + match ← (coreM.run' coreContext { env := env }).toBaseIO with + | .error exception => + return LSpec.test "Exception" (s!"internal exception #{← exception.toMessageData.toString}" = "") + | .ok (_, a) => + return a + +/-- M-coupled goals -/ +def test_m_couple: TestM Unit := do + let state? ← startProof "(2: Nat) ≤ 5" + let state0 ← match state? with + | .some state => pure state + | .none => do + addTest $ assertUnreachable "Goal could not parse" + return () + + let state1 ← match ← state0.tacticOn (goalId := 0) (tactic := "apply Nat.le_trans") with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check "apply Nat.le_trans" ((← state1.serializeGoals (options := ← read)).map (·.target.pp?) = + #[.some "2 ≤ ?m", .some "?m ≤ 5", .some "Nat"]) + addTest $ LSpec.test "(1 root)" state1.rootExpr?.isNone + -- Set m to 3 + let state2 ← match ← state1.tacticOn (goalId := 2) (tactic := "exact 3") with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.test "(1b root)" state2.rootExpr?.isNone + let state1b ← match state2.continue state1 with + | .error msg => do + addTest $ assertUnreachable $ msg + return () + | .ok state => pure state + addTest $ LSpec.check "exact 3" ((← state1b.serializeGoals (options := ← read)).map (·.target.pp?) = + #[.some "2 ≤ 3", .some "3 ≤ 5"]) + addTest $ LSpec.test "(2 root)" state1b.rootExpr?.isNone + +def test_m_couple_simp: TestM Unit := do + let state? ← startProof "(2: Nat) ≤ 5" + let state0 ← match state? with + | .some state => pure state + | .none => do + addTest $ assertUnreachable "Goal could not parse" + return () + + let state1 ← match ← state0.tacticOn (goalId := 0) (tactic := "apply Nat.le_trans") with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + let serializedState1 ← state1.serializeGoals (options := { ← read with printDependentMVars := true }) + addTest $ LSpec.check "apply Nat.le_trans" (serializedState1.map (·.target.pp?) = + #[.some "2 ≤ ?m", .some "?m ≤ 5", .some "Nat"]) + addTest $ LSpec.check "(metavariables)" (serializedState1.map (·.target.dependentMVars?.get!) = + #[#["_uniq.38"], #["_uniq.38"], #[]]) + + let state2 ← match ← state1.tacticOn (goalId := 2) (tactic := "exact 2") with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.test "(1b root)" state2.rootExpr?.isNone + let state1b ← match state2.continue state1 with + | .error msg => do + addTest $ assertUnreachable $ msg + return () + | .ok state => pure state + addTest $ LSpec.check "exact 2" ((← state1b.serializeGoals (options := ← read)).map (·.target.pp?) = + #[.some "2 ≤ 2", .some "2 ≤ 5"]) + addTest $ LSpec.test "(2 root)" state1b.rootExpr?.isNone + let state3 ← match ← state1b.tacticOn (goalId := 0) (tactic := "simp") with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + let state4 ← match state3.continue state1b with + | .error msg => do + addTest $ assertUnreachable $ msg + return () + | .ok state => pure state + let state5 ← match ← state4.tacticOn (goalId := 0) (tactic := "simp") with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + + state5.restoreMetaM + let root ← match state5.rootExpr? with + | .some e => pure e + | .none => + addTest $ assertUnreachable "(5 root)" + return () + let rootStr: String := toString (← Lean.Meta.ppExpr root) + addTest $ LSpec.check "(5 root)" (rootStr = "Nat.le_trans (of_eq_true (Init.Data.Nat.Basic._auxLemma.4 2)) (of_eq_true (eq_true_of_decide (Eq.refl true)))") + let unfoldedRoot ← unfoldAuxLemmas root + addTest $ LSpec.check "(5 root)" ((toString (← Lean.Meta.ppExpr unfoldedRoot)) = + "Nat.le_trans (of_eq_true (eq_true (Nat.le_refl 2))) (of_eq_true (eq_true_of_decide (Eq.refl true)))") + return () + +def test_proposition_generation: TestM Unit := do + let state? ← startProof "Σ' p:Prop, p" + let state0 ← match state? with + | .some state => pure state + | .none => do + addTest $ assertUnreachable "Goal could not parse" + return () + + let state1 ← match ← state0.tacticOn (goalId := 0) (tactic := "apply PSigma.mk") with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check "apply PSigma.mk" ((← state1.serializeGoals (options := ← read)).map (·.devolatilize) = + #[ + buildGoal [] "?fst" (userName? := .some "snd"), + buildGoal [] "Prop" (userName? := .some "fst") + ]) + if let #[goal1, goal2] := ← state1.serializeGoals (options := { (← read) with printExprAST := true }) then + addTest $ LSpec.test "(1 reference)" (goal1.target.sexp? = .some s!"(:mv {goal2.name})") + addTest $ LSpec.test "(1 root)" state1.rootExpr?.isNone + + let state2 ← match ← state1.tryAssign (state1.get! 0) (expr := "λ (x: Nat) => _") with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check ":= λ (x: Nat), _" ((← state2.serializeGoals (options := ← read)).map (·.target.pp?) = + #[.some "?m.29 x"]) + addTest $ LSpec.test "(2 root)" state2.rootExpr?.isNone + + let assign := "Eq.refl x" + let state3 ← match ← state2.tryAssign (state2.get! 0) (expr := assign) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check s!":= {assign}" ((← state3.serializeGoals (options := ← read)).map (·.target.pp?) = + #[]) + + addTest $ LSpec.test "(3 root)" state3.rootExpr?.isSome + return () + +def test_partial_continuation: TestM Unit := do + let state? ← startProof "(2: Nat) ≤ 5" + let state0 ← match state? with + | .some state => pure state + | .none => do + addTest $ assertUnreachable "Goal could not parse" + return () + + let state1 ← match ← state0.tacticOn (goalId := 0) (tactic := "apply Nat.le_trans") with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check "apply Nat.le_trans" ((← state1.serializeGoals (options := ← read)).map (·.target.pp?) = + #[.some "2 ≤ ?m", .some "?m ≤ 5", .some "Nat"]) + + let state2 ← match ← state1.tacticOn (goalId := 2) (tactic := "apply Nat.succ") with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check "apply Nat.succ" ((← state2.serializeGoals (options := ← read)).map (·.target.pp?) = + #[.some "Nat"]) + + -- Execute a partial continuation + let coupled_goals := state1.goals ++ state2.goals + let state1b ← match state2.resume (goals := coupled_goals) with + | .error msg => do + addTest $ assertUnreachable $ msg + return () + | .ok state => pure state + addTest $ LSpec.check "(continue)" ((← state1b.serializeGoals (options := ← read)).map (·.target.pp?) = + #[.some "2 ≤ ?m.succ", .some "?m.succ ≤ 5", .some "Nat"]) + addTest $ LSpec.test "(2 root)" state1b.rootExpr?.isNone + + -- Roundtrip + --let coupled_goals := coupled_goals.map (λ g => + -- { name := str_to_name $ serializeName g.name (sanitize := false)}) + let coupled_goals := coupled_goals.map (λ g => serializeName g.name (sanitize := false)) + let coupled_goals := coupled_goals.map (λ g => { name := g.toName }) + let state1b ← match state2.resume (goals := coupled_goals) with + | .error msg => do + addTest $ assertUnreachable $ msg + return () + | .ok state => pure state + addTest $ LSpec.check "(continue)" ((← state1b.serializeGoals (options := ← read)).map (·.target.pp?) = + #[.some "2 ≤ ?m.succ", .some "?m.succ ≤ 5", .some "Nat"]) + addTest $ LSpec.test "(2 root)" state1b.rootExpr?.isNone + + -- Continuation should fail if the state does not exist: + match state0.resume coupled_goals with + | .error error => addTest $ LSpec.check "(continuation failure message)" (error = "Goals [_uniq.40, _uniq.41, _uniq.38, _uniq.47] are not in scope") + | .ok _ => addTest $ assertUnreachable "(continuation failure)" + -- Continuation should fail if some goals have not been solved + match state2.continue state1 with + | .error error => addTest $ LSpec.check "(continuation failure message)" (error = "Target state has unresolved goals") + | .ok _ => addTest $ assertUnreachable "(continuation failure)" + return () + + +def suite (env: Environment): List (String × IO LSpec.TestSeq) := + let tests := [ + ("Instantiate", test_instantiate_mvar), + ("2 < 5", test_m_couple), + ("2 < 5", test_m_couple_simp), + ("Proposition Generation", test_proposition_generation), + ("Partial Continuation", test_partial_continuation) + ] + tests.map (fun (name, test) => (name, proofRunner env test)) + +end Pantograph.Test.Metavar diff --git a/Test/Proofs.lean b/Test/Proofs.lean index 52854d4..a6b5487 100644 --- a/Test/Proofs.lean +++ b/Test/Proofs.lean @@ -1,8 +1,12 @@ +/- +Tests pertaining to goals with no interdependencies +-/ import LSpec -import Pantograph.Meta -import Pantograph.Serial +import Pantograph.Goal +import Pantograph.Delate +import Test.Common -namespace Pantograph.Test +namespace Pantograph.Test.Proofs open Pantograph open Lean @@ -10,118 +14,201 @@ inductive Start where | copy (name: String) -- Start from some name in the environment | expr (expr: String) -- Start from some expression -abbrev TestM := StateRefT ProofTree M +abbrev TestM := TestT $ ReaderT Protocol.Options $ Elab.TermElabM -def start_proof (start: Start): M (LSpec.TestSeq × Option ProofTree) := do +def startProof (start: Start): TestM (Option GoalState) := do let env ← Lean.MonadEnv.getEnv - let mut testSeq := LSpec.TestSeq.done match start with | .copy name => - let cInfo? := str_to_name name |> env.find? - testSeq := testSeq ++ LSpec.check s!"Symbol exists {name}" cInfo?.isSome + let cInfo? := name.toName |> env.find? + addTest $ LSpec.check s!"Symbol exists {name}" cInfo?.isSome match cInfo? with | .some cInfo => - let state ← ProofTree.create - (name := str_to_name "TestExample") - (expr := cInfo.type) - return (testSeq, Option.some state) + let goal ← GoalState.create (expr := cInfo.type) + return Option.some goal | .none => - return (testSeq, Option.none) + return Option.none | .expr expr => - let syn? := syntax_from_str env expr - testSeq := testSeq ++ LSpec.check s!"Parsing {expr}" (syn?.isOk) + let syn? := parseTerm env expr + addTest $ LSpec.check s!"Parsing {expr}" (syn?.isOk) match syn? with | .error error => IO.println error - return (testSeq, Option.none) + return Option.none | .ok syn => - let expr? ← syntax_to_expr syn - testSeq := testSeq ++ LSpec.check s!"Elaborating" expr?.isOk + let expr? ← elabType syn + addTest $ LSpec.check s!"Elaborating" expr?.isOk match expr? with | .error error => IO.println error - return (testSeq, Option.none) + return Option.none | .ok expr => - let state ← ProofTree.create - (name := str_to_name "TestExample") - (expr := expr) - return (testSeq, Option.some state) + let goal ← GoalState.create (expr := expr) + return Option.some goal -deriving instance DecidableEq, Repr for Variable -deriving instance DecidableEq, Repr for Goal -deriving instance DecidableEq, Repr for TacticResult - -def proof_step (stateId: Nat) (goalId: Nat) (tactic: String) - (expected: TacticResult) : TestM LSpec.TestSeq := do - let result: TacticResult ← ProofTree.execute stateId goalId tactic - match expected, result with - | .success (.some i) #[], .success (.some _) goals => - -- If the goals are omitted but the next state is specified, we imply that - -- the tactic succeeded. - let expected := .success (.some i) goals - return LSpec.test s!"{stateId}.{goalId} {tactic}" (result = expected) - | _, _ => - return LSpec.test s!"{stateId}.{goalId} {tactic}" (result = expected) - -def proof_inspect (expected: Array String) : TestM LSpec.TestSeq := do - let result := (← get).structure_array - return LSpec.test s!"tree structure" (result = expected) - -def proof_runner (env: Lean.Environment) (start: Start) (steps: List (TestM LSpec.TestSeq)): IO LSpec.TestSeq := do - let termElabM := do - let (testSeq, state?) ← start_proof start - match state? with - | .none => return testSeq - | .some state => steps.foldlM (fun tests m => do pure $ tests ++ (← m)) testSeq |>.run' state - - let coreContext: Lean.Core.Context := { - currNamespace := str_to_name "Aniva", - openDecls := [], -- No 'open' directives needed - fileName := "", - fileMap := { source := "", positions := #[0], lines := #[1] } +def buildNamedGoal (name: String) (nameType: List (String × String)) (target: String) + (userName?: Option String := .none): Protocol.Goal := + { + name, + userName?, + target := { pp? := .some target}, + vars := (nameType.map fun x => ({ + userName := x.fst, + type? := .some { pp? := .some x.snd }, + })).toArray } - let metaM := termElabM.run' (ctx := { - declName? := some "_pantograph", - errToSorry := false - }) +def buildGoal (nameType: List (String × String)) (target: String) (userName?: Option String := .none): + Protocol.Goal := + { + userName?, + target := { pp? := .some target}, + vars := (nameType.map fun x => ({ + userName := x.fst, + type? := .some { pp? := .some x.snd }, + })).toArray + } +def proofRunner (env: Lean.Environment) (tests: TestM Unit): IO LSpec.TestSeq := do + let termElabM := tests.run LSpec.TestSeq.done |>.run {} -- with default options + + let coreContext: Lean.Core.Context ← createCoreContext #[] + let metaM := termElabM.run' (ctx := defaultElabContext) let coreM := metaM.run' match ← (coreM.run' coreContext { env := env }).toBaseIO with | .error exception => return LSpec.test "Exception" (s!"internal exception #{← exception.toMessageData.toString}" = "") - | .ok a => return a + | .ok (_, a) => + return a -def build_goal (nameType: List (String × String)) (target: String): Goal := - { - target := target, - vars := (nameType.map fun x => ({ name := x.fst, type := x.snd }: Variable)).toArray - } +def test_identity: TestM Unit := do + let state? ← startProof (.expr "∀ (p: Prop), p → p") + let state0 ← match state? with + | .some state => pure state + | .none => do + addTest $ assertUnreachable "Goal could not parse" + return () + let tactic := "intro p h" + let state1 ← match ← state0.tacticOn 0 tactic with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + let inner := "_uniq.12" + addTest $ LSpec.check tactic ((← state1.serializeGoals (options := ← read)).map (·.name) = + #[inner]) + let state1parent ← state1.withParentContext do + serializeExpressionSexp (← instantiateAll state1.parentExpr?.get!) (sanitize := false) + addTest $ LSpec.test "(1 parent)" (state1parent == s!"(:lambda p (:sort 0) (:lambda h 0 (:subst (:mv {inner}) 1 0)))") + +-- Individual test cases example: ∀ (a b: Nat), a + b = b + a := by intro n m rw [Nat.add_comm] -def proof_nat_add_comm (env: Lean.Environment): IO LSpec.TestSeq := do - let goal1: Goal := { - target := "n + m = m + n", - vars := #[{ name := "n", type := "Nat" }, { name := "m", type := "Nat" }] - } - proof_runner env (.copy "Nat.add_comm") [ - proof_step 0 0 "intro n m" - (.success (.some 1) #[goal1]), - proof_step 1 0 "assumption" - (.failure #[s!"tactic 'assumption' failed\nn m : Nat\n⊢ n + m = m + n"]), - proof_step 1 0 "rw [Nat.add_comm]" - (.success .none #[]) - ] -def proof_nat_add_comm_manual (env: Lean.Environment): IO LSpec.TestSeq := do - let goal1: Goal := build_goal [("n", "Nat"), ("m", "Nat")] "n + m = m + n" - proof_runner env (.expr "∀ (a b: Nat), a + b = b + a") [ - proof_step 0 0 "intro n m" - (.success (.some 1) #[goal1]), - proof_step 1 0 "assumption" - (.failure #[s!"tactic 'assumption' failed\nn m : Nat\n⊢ n + m = m + n"]), - proof_step 1 0 "rw [Nat.add_comm]" - (.success .none #[]) - ] +def test_nat_add_comm (manual: Bool): TestM Unit := do + let state? ← startProof <| match manual with + | false => .copy "Nat.add_comm" + | true => .expr "∀ (a b: Nat), a + b = b + a" + addTest $ LSpec.check "Start goal" state?.isSome + let state0 ← match state? with + | .some state => pure state + | .none => do + addTest $ assertUnreachable "Goal could not parse" + return () + + let state1 ← match ← state0.tacticOn 0 "intro n m" with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check "intro n m" ((← state1.serializeGoals (options := ← read)).map (·.devolatilize) = + #[buildGoal [("n", "Nat"), ("m", "Nat")] "n + m = m + n"]) + + match ← state1.tacticOn 0 "assumption" with + | .failure #[message] => + addTest $ LSpec.check "assumption" (message = "tactic 'assumption' failed\nn m : Nat\n⊢ n + m = m + n") + | other => do + addTest $ assertUnreachable $ other.toString + + let state2 ← match ← state1.tacticOn 0 "rw [Nat.add_comm]" with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.test "rw [Nat.add_comm]" state2.goals.isEmpty + + return () +def test_delta_variable: TestM Unit := do + let options: Protocol.Options := { noRepeat := true } + let state? ← startProof <| .expr "∀ (a b: Nat), a + b = b + a" + addTest $ LSpec.check "Start goal" state?.isSome + let state0 ← match state? with + | .some state => pure state + | .none => do + addTest $ assertUnreachable "Goal could not parse" + return () + + let state1 ← match ← state0.tacticOn (goalId := 0) (tactic := "intro n") with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check "intro n" ((← state1.serializeGoals (parent := state0) options).map (·.devolatilize) = + #[buildGoalSelective [("n", .some "Nat")] "∀ (b : Nat), n + b = b + n"]) + let state2 ← match ← state1.tacticOn (goalId := 0) (tactic := "intro m") with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check "intro m" ((← state2.serializeGoals (parent := state1) options).map (·.devolatilize) = + #[buildGoalSelective [("n", .none), ("m", .some "Nat")] "n + m = m + n"]) + return () + where +-- Like `buildGoal` but allow certain variables to be elided. + buildGoalSelective (nameType: List (String × Option String)) (target: String): Protocol.Goal := + { + target := { pp? := .some target}, + vars := (nameType.map fun x => ({ + userName := x.fst, + type? := x.snd.map (λ type => { pp? := type }), + })).toArray + } + +example (w x y z : Nat) (p : Nat → Prop) + (h : p (x * y + z * w * x)) : p (x * w * z + y * x) := by + simp [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm, Nat.mul_comm, Nat.mul_assoc, Nat.mul_left_comm] at * + assumption +def test_arith: TestM Unit := do + let state? ← startProof (.expr "∀ (w x y z : Nat) (p : Nat → Prop) (h : p (x * y + z * w * x)), p (x * w * z + y * x)") + let state0 ← match state? with + | .some state => pure state + | .none => do + addTest $ assertUnreachable "Goal could not parse" + return () + + let tactic := "intros" + let state1 ← match ← state0.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check tactic (state1.goals.length = 1) + addTest $ LSpec.test "(1 root)" state1.rootExpr?.isNone + let state2 ← match ← state1.tacticOn (goalId := 0) (tactic := "simp [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm, Nat.mul_comm, Nat.mul_assoc, Nat.mul_left_comm] at *") with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check "simp ..." (state2.goals.length = 1) + addTest $ LSpec.check "(2 root)" state2.rootExpr?.isNone + let tactic := "assumption" + let state3 ← match ← state2.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.test tactic state3.goals.isEmpty + addTest $ LSpec.check "(3 root)" state3.rootExpr?.isSome + return () -- Two ways to write the same theorem example: ∀ (p q: Prop), p ∨ q → q ∨ p := by @@ -138,59 +225,549 @@ example: ∀ (p q: Prop), p ∨ q → q ∨ p := by assumption . apply Or.inl assumption -def proof_or_comm (env: Lean.Environment): IO LSpec.TestSeq := do - let branchGoal (caseName name: String): Goal := { - caseName? := .some caseName, - target := "q ∨ p", - vars := #[ - { name := "p", type := "Prop" }, - { name := "q", type := "Prop" }, - { name := "h✝", type := name, isInaccessible := true } - ] - } - proof_runner env (.expr "∀ (p q: Prop), p ∨ q → q ∨ p") [ - proof_step 0 0 "intro p q h" - (.success (.some 1) #[build_goal [("p", "Prop"), ("q", "Prop"), ("h", "p ∨ q")] "q ∨ p"]), - proof_step 1 0 "cases h" - (.success (.some 2) #[branchGoal "inl" "p", branchGoal "inr" "q"]), - proof_inspect #["", "0.0", "1.0"], - proof_step 2 0 "apply Or.inr" - (.success (.some 3) #[]), - proof_inspect #["", "0.0", "1.0", "2.0"], - proof_step 3 0 "assumption" - (.success .none #[]), - proof_step 2 1 "apply Or.inl" - (.success (.some 4) #[]), - proof_step 4 0 "assumption" - (.success .none #[]), - proof_inspect #["", "0.0", "1.0", "2.0", "2.1"] +def test_or_comm: TestM Unit := do + let state? ← startProof (.expr "∀ (p q: Prop), p ∨ q → q ∨ p") + let state0 ← match state? with + | .some state => pure state + | .none => do + addTest $ assertUnreachable "Goal could not parse" + return () + addTest $ LSpec.check "(0 parent)" state0.parentExpr?.isNone + addTest $ LSpec.check "(0 root)" state0.rootExpr?.isNone + + let tactic := "intro p q h" + let state1 ← match ← state0.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + let fvP := "_uniq.10" + let fvQ := "_uniq.13" + let fvH := "_uniq.16" + let state1g0 := "_uniq.17" + addTest $ LSpec.check tactic ((← state1.serializeGoals (options := ← read)) = + #[{ + name := state1g0, + target := { pp? := .some "q ∨ p" }, + vars := #[ + { name := fvP, userName := "p", type? := .some { pp? := .some "Prop" } }, + { name := fvQ, userName := "q", type? := .some { pp? := .some "Prop" } }, + { name := fvH, userName := "h", type? := .some { pp? := .some "p ∨ q" } } + ] + }]) + addTest $ LSpec.check "(1 parent)" state1.parentExpr?.isSome + addTest $ LSpec.check "(1 root)" state1.rootExpr?.isNone + + let state1parent ← state1.withParentContext do + serializeExpressionSexp (← instantiateAll state1.parentExpr?.get!) (sanitize := false) + addTest $ LSpec.test "(1 parent)" (state1parent == s!"(:lambda p (:sort 0) (:lambda q (:sort 0) (:lambda h ((:c Or) 1 0) (:subst (:mv {state1g0}) 2 1 0))))") + let tactic := "cases h" + let state2 ← match ← state1.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check tactic ((← state2.serializeGoals (options := ← read)).map (·.devolatilize) = + #[branchGoal "inl" "p", branchGoal "inr" "q"]) + let (caseL, caseR) := ("_uniq.64", "_uniq.77") + addTest $ LSpec.check tactic ((← state2.serializeGoals (options := ← read)).map (·.name) = + #[caseL, caseR]) + addTest $ LSpec.check "(2 parent exists)" state2.parentExpr?.isSome + addTest $ LSpec.check "(2 root)" state2.rootExpr?.isNone + + let state2parent ← state2.withParentContext do + serializeExpressionSexp (← instantiateAll state2.parentExpr?.get!) (sanitize := false) + let orPQ := s!"((:c Or) (:fv {fvP}) (:fv {fvQ}))" + let orQP := s!"((:c Or) (:fv {fvQ}) (:fv {fvP}))" + let motive := s!"(:lambda t {orPQ} (:forall h ((:c Eq) ((:c Or) (:fv {fvP}) (:fv {fvQ})) (:fv {fvH}) 0) {orQP}))" + let caseL := s!"(:lambda h (:fv {fvP}) (:lambda h ((:c Eq) {orPQ} (:fv {fvH}) ((:c Or.inl) (:fv {fvP}) (:fv {fvQ}) 0)) (:subst (:mv {caseL}) (:fv {fvP}) (:fv {fvQ}) 1)))" + let caseR := s!"(:lambda h (:fv {fvQ}) (:lambda h ((:c Eq) {orPQ} (:fv {fvH}) ((:c Or.inr) (:fv {fvP}) (:fv {fvQ}) 0)) (:subst (:mv {caseR}) (:fv {fvP}) (:fv {fvQ}) 1)))" + let conduit := s!"((:c Eq.refl) {orPQ} (:fv {fvH}))" + addTest $ LSpec.test "(2 parent)" (state2parent == + s!"((:c Or.casesOn) (:fv {fvP}) (:fv {fvQ}) {motive} (:fv {fvH}) {caseL} {caseR} {conduit})") + + let state3_1 ← match ← state2.tacticOn (goalId := 0) (tactic := "apply Or.inr") with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + let state3_1parent ← state3_1.withParentContext do + serializeExpressionSexp (← instantiateAll state3_1.parentExpr?.get!) (sanitize := false) + addTest $ LSpec.test "(3_1 parent)" (state3_1parent == s!"((:c Or.inr) (:fv {fvQ}) (:fv {fvP}) (:mv _uniq.91))") + addTest $ LSpec.check "· apply Or.inr" (state3_1.goals.length = 1) + let state4_1 ← match ← state3_1.tacticOn (goalId := 0) (tactic := "assumption") with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check " assumption" state4_1.goals.isEmpty + let state4_1parent ← instantiateAll state4_1.parentExpr?.get! + addTest $ LSpec.test "(4_1 parent)" state4_1parent.isFVar + addTest $ LSpec.check "(4_1 root)" state4_1.rootExpr?.isNone + let state3_2 ← match ← state2.tacticOn (goalId := 1) (tactic := "apply Or.inl") with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check "· apply Or.inl" (state3_2.goals.length = 1) + let state4_2 ← match ← state3_2.tacticOn (goalId := 0) (tactic := "assumption") with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check " assumption" state4_2.goals.isEmpty + addTest $ LSpec.check "(4_2 root)" state4_2.rootExpr?.isNone + -- Ensure the proof can continue from `state4_2`. + let state2b ← match state4_2.continue state2 with + | .error msg => do + addTest $ assertUnreachable $ msg + return () + | .ok state => pure state + addTest $ LSpec.test "(resume)" (state2b.goals == [state2.goals.get! 0]) + let state3_1 ← match ← state2b.tacticOn (goalId := 0) (tactic := "apply Or.inr") with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check "· apply Or.inr" (state3_1.goals.length = 1) + let state4_1 ← match ← state3_1.tacticOn (goalId := 0) (tactic := "assumption") with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check " assumption" state4_1.goals.isEmpty + addTest $ LSpec.check "(4_1 root)" state4_1.rootExpr?.isSome + + return () + where + typeProp: Protocol.Expression := { pp? := .some "Prop" } + branchGoal (caseName varName: String): Protocol.Goal := { + userName? := .some caseName, + target := { pp? := .some "q ∨ p" }, + vars := #[ + { userName := "p", type? := .some typeProp }, + { userName := "q", type? := .some typeProp }, + { userName := "h✝", type? := .some { pp? := .some varName }, isInaccessible := true } + ] + } + +example : ∀ (a b c1 c2: Nat), (b + a) + c1 = (b + a) + c2 → (a + b) + c1 = (b + a) + c2 := by + intro a b c1 c2 h + conv => + lhs + congr + . rw [Nat.add_comm] + . rfl + exact h + +def test_conv: TestM Unit := do + let state? ← startProof (.expr "∀ (a b c1 c2: Nat), (b + a) + c1 = (b + a) + c2 → (a + b) + c1 = (b + a) + c2") + let state0 ← match state? with + | .some state => pure state + | .none => do + addTest $ assertUnreachable "Goal could not parse" + return () + + let tactic := "intro a b c1 c2 h" + let state1 ← match ← state0.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check tactic ((← state1.serializeGoals (options := ← read)).map (·.devolatilize) = + #[interiorGoal [] "a + b + c1 = b + a + c2"]) + + let state2 ← match ← state1.conv (state1.get! 0) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check "conv => ..." ((← state2.serializeGoals (options := ← read)).map (·.devolatilize) = + #[{ interiorGoal [] "a + b + c1 = b + a + c2" with isConversion := true }]) + + let convTactic := "rhs" + let state3R ← match ← state2.tacticOn (goalId := 0) convTactic with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check s!" {convTactic} (discard)" ((← state3R.serializeGoals (options := ← read)).map (·.devolatilize) = + #[{ interiorGoal [] "b + a + c2" with isConversion := true }]) + + let convTactic := "lhs" + let state3L ← match ← state2.tacticOn (goalId := 0) convTactic with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check s!" {convTactic}" ((← state3L.serializeGoals (options := ← read)).map (·.devolatilize) = + #[{ interiorGoal [] "a + b + c1" with isConversion := true }]) + + let convTactic := "congr" + let state4 ← match ← state3L.tacticOn (goalId := 0) convTactic with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check s!" {convTactic}" ((← state4.serializeGoals (options := ← read)).map (·.devolatilize) = + #[ + { interiorGoal [] "a + b" with isConversion := true, userName? := .some "a" }, + { interiorGoal [] "c1" with isConversion := true, userName? := .some "a" } + ]) + + let convTactic := "rw [Nat.add_comm]" + let state5_1 ← match ← state4.tacticOn (goalId := 0) convTactic with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check s!" · {convTactic}" ((← state5_1.serializeGoals (options := ← read)).map (·.devolatilize) = + #[{ interiorGoal [] "b + a" with isConversion := true, userName? := .some "a" }]) + + let convTactic := "rfl" + let state6_1 ← match ← state5_1.tacticOn (goalId := 0) convTactic with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check s!" {convTactic}" ((← state6_1.serializeGoals (options := ← read)).map (·.devolatilize) = + #[]) + + let state4_1 ← match state6_1.continue state4 with + | .ok state => pure state + | .error e => do + addTest $ expectationFailure "continue" e + return () + + let convTactic := "rfl" + let state6 ← match ← state4_1.tacticOn (goalId := 0) convTactic with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check s!" · {convTactic}" ((← state6.serializeGoals (options := ← read)).map (·.devolatilize) = + #[]) + + let state1_1 ← match ← state6.convExit with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + + let tactic := "exact h" + let stateF ← match ← state1_1.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check tactic ((← stateF.serializeGoals (options := ← read)).map (·.devolatilize) = + #[]) + + where + h := "b + a + c1 = b + a + c2" + interiorGoal (free: List (String × String)) (target: String) := + let free := [("a", "Nat"), ("b", "Nat"), ("c1", "Nat"), ("c2", "Nat"), ("h", h)] ++ free + buildGoal free target + +example : ∀ (a b c d: Nat), a + b = b + c → b + c = c + d → a + b = c + d := by + intro a b c d h1 h2 + calc a + b = b + c := by apply h1 + _ = c + d := by apply h2 + +def test_calc: TestM Unit := do + let state? ← startProof (.expr "∀ (a b c d: Nat), a + b = b + c → b + c = c + d → a + b = c + d") + let state0 ← match state? with + | .some state => pure state + | .none => do + addTest $ assertUnreachable "Goal could not parse" + return () + let tactic := "intro a b c d h1 h2" + let state1 ← match ← state0.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check tactic ((← state1.serializeGoals (options := ← read)).map (·.devolatilize) = + #[interiorGoal [] "a + b = c + d"]) + let pred := "a + b = b + c" + let state2 ← match ← state1.tryCalc (state1.get! 0) (pred := pred) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check s!"calc {pred} := _" ((← state2.serializeGoals (options := ← read)).map (·.devolatilize) = + #[ + interiorGoal [] "a + b = b + c" (.some "calc"), + interiorGoal [] "b + c = c + d" + ]) + addTest $ LSpec.test "(2.0 prev rhs)" (state2.calcPrevRhsOf? (state2.get! 0) |>.isNone) + addTest $ LSpec.test "(2.1 prev rhs)" (state2.calcPrevRhsOf? (state2.get! 1) |>.isSome) + + let tactic := "apply h1" + let state2m ← match ← state2.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + let state3 ← match state2m.continue state2 with + | .ok state => pure state + | .error e => do + addTest $ expectationFailure "continue" e + return () + let pred := "_ = c + d" + let state4 ← match ← state3.tryCalc (state3.get! 0) (pred := pred) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check s!"calc {pred} := _" ((← state4.serializeGoals (options := ← read)).map (·.devolatilize) = + #[ + interiorGoal [] "b + c = c + d" (.some "calc") + ]) + addTest $ LSpec.test "(4.0 prev rhs)" (state4.calcPrevRhsOf? (state4.get! 0) |>.isNone) + let tactic := "apply h2" + let state4m ← match ← state4.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.test "(4m root)" state4m.rootExpr?.isSome + where + interiorGoal (free: List (String × String)) (target: String) (userName?: Option String := .none) := + let free := [("a", "Nat"), ("b", "Nat"), ("c", "Nat"), ("d", "Nat"), + ("h1", "a + b = b + c"), ("h2", "b + c = c + d")] ++ free + buildGoal free target userName? + +def test_nat_zero_add: TestM Unit := do + let state? ← startProof (.expr "∀ (n: Nat), n + 0 = n") + let state0 ← match state? with + | .some state => pure state + | .none => do + addTest $ assertUnreachable "Goal could not parse" + return () + let tactic := "intro n" + let state1 ← match ← state0.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check tactic ((← state1.serializeGoals (options := ← read)).map (·.devolatilize) = + #[buildGoal [("n", "Nat")] "n + 0 = n"]) + let recursor := "@Nat.brecOn" + let state2 ← match ← state1.tryMotivatedApply (state1.get! 0) (recursor := recursor) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + 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 "_uniq.69" [("n", "Nat")] "∀ (t : Nat), Nat.below t → ?motive t", + buildNamedGoal "_uniq.70" [("n", "Nat")] "?motive ?m.68 = (n + 0 = n)" (.some "conduit") + ]) + + let tactic := "exact n" + let state3b ← match ← state2.tacticOn (goalId := 1) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check tactic ((← state3b.serializeGoals (options := ← read)).map (·.devolatilize) = + #[]) + let state2b ← match state3b.continue state2 with + | .ok state => pure state + | .error e => do + addTest $ assertUnreachable e + return () + let tactic := "exact (λ x => x + 0 = x)" + let state3c ← match ← state2b.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check tactic ((← state3c.serializeGoals (options := ← read)).map (·.devolatilize) = + #[]) + let state2c ← match state3c.continue state2b with + | .ok state => pure state + | .error e => do + addTest $ assertUnreachable e + return () + let tactic := "intro t h" + let state3 ← match ← state2c.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check tactic ((← state3.serializeGoals (options := ← read)).map (·.devolatilize) = + #[buildGoal [("n", "Nat"), ("t", "Nat"), ("h", "Nat.below t")] "t + 0 = t"]) + + let tactic := "simp" + let state3d ← match ← state3.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + let state2d ← match state3d.continue state2c with + | .ok state => pure state + | .error e => do + addTest $ assertUnreachable e + return () + let tactic := "rfl" + let stateF ← match ← state2d.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check tactic ((← stateF.serializeGoals (options := ← read)) = + #[]) + + let expr := stateF.mctx.eAssignment.find! stateF.root + let (expr, _) := instantiateMVarsCore (mctx := stateF.mctx) (e := expr) + addTest $ LSpec.check "(F root)" stateF.rootExpr?.isSome + +def test_nat_zero_add_alt: TestM Unit := do + let state? ← startProof (.expr "∀ (n: Nat), n + 0 = n") + let state0 ← match state? with + | .some state => pure state + | .none => do + addTest $ assertUnreachable "Goal could not parse" + return () + let tactic := "intro n" + let state1 ← match ← state0.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check tactic ((← state1.serializeGoals (options := ← read)).map (·.devolatilize) = + #[buildGoal [("n", "Nat")] "n + 0 = n"]) + let recursor := "@Nat.brecOn" + let state2 ← match ← state1.tryMotivatedApply (state1.get! 0) (recursor := recursor) with + | .success state => pure state + | 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 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") + ]) + + let tactic := "intro x" + let state3m ← match ← state2.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check tactic ((← state3m.serializeGoals (options := ← read)).map (·.devolatilize) = + #[buildGoal [("n", "Nat"), ("x", "Nat")] "Prop" (.some "motive")]) + let tactic := "apply Eq" + let state3m2 ← match ← state3m.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + let (eqL, eqR, eqT) := ("_uniq.88", "_uniq.89", "_uniq.87") + 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 + | .error e => do + addTest $ assertUnreachable e + return () + + let cNatAdd := "(:c HAdd.hAdd) (:c Nat) (:c Nat) (:c Nat) ((:c instHAdd) (:c Nat) (:c instAddNat))" + let cNat0 := "((:c OfNat.ofNat) (:c Nat) (:lit 0) ((:c instOfNatNat) (:lit 0)))" + let fvN := "_uniq.63" + let conduitRight := s!"((:c Eq) (:c Nat) ({cNatAdd} (:fv {fvN}) {cNat0}) (:fv {fvN}))" + let substOf (mv: String) := s!"(:subst (:mv {mv}) (:fv {fvN}) (:mv {major}))" + addTest $ LSpec.check "resume" ((← state2b.serializeGoals (options := { ← read with printExprAST := true })) = + #[ + { + name := "_uniq.70", + userName? := .some "conduit", + target := { + pp? := .some "(?m.92 ?m.68 = ?m.94 ?m.68) = (n + 0 = n)", + sexp? := .some s!"((:c Eq) (:sort 0) ((:c Eq) {substOf eqT} {substOf eqL} {substOf eqR}) {conduitRight})", + }, + vars := #[{ + name := fvN, + userName := "n", + type? := .some { pp? := .some "Nat", sexp? := .some "(:c Nat)" }, + }], + } + ]) + +def test_tactic_failure_unresolved_goals : TestM Unit := do + let state? ← startProof (.expr "∀ (p : Nat → Prop), ∃ (x : Nat), p (0 + x + 0)") + let state0 ← match state? with + | .some state => pure state + | .none => do + addTest $ assertUnreachable "Goal could not parse" + return () + + let tactic := "intro p" + let state1 ← match ← state0.tacticOn 0 tactic with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + + let tactic := "exact ⟨0, by simp⟩" + let .failure messages ← state1.tacticOn 0 tactic | addTest $ assertUnreachable s!"{tactic} should fail" + checkEq s!"{tactic} fails" messages #[s!"{← getFileName}:0:12: error: unsolved goals\np : Nat → Prop\n⊢ p 0\n"] + + +def test_tactic_failure_synthesize_placeholder : TestM Unit := do + let state? ← startProof (.expr "∀ (p q r : Prop) (h : p → q), q ∧ r") + let state0 ← match state? with + | .some state => pure state + | .none => do + addTest $ assertUnreachable "Goal could not parse" + return () + + let tactic := "intro p q r h" + let state1 ← match ← state0.tacticOn 0 tactic with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + + let tactic := "simpa [h] using And.imp_left h _" + let state2 ← match ← state1.tacticOn 0 tactic with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + + checkEq tactic ((← state2.serializeGoals).map (·.devolatilize)) #[ + buildGoal [("p", "Prop"), ("q", "Prop"), ("r", "Prop"), ("h", "p → q")] "p ∧ r" ] -example (w x y z : Nat) (p : Nat → Prop) - (h : p (x * y + z * w * x)) : p (x * w * z + y * x) := by - simp [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm, Nat.mul_comm, Nat.mul_assoc, Nat.mul_left_comm] at * - assumption -def proof_arith_1 (env: Lean.Environment): IO LSpec.TestSeq := do - proof_runner env (.expr "∀ (w x y z : Nat) (p : Nat → Prop) (h : p (x * y + z * w * x)), p (x * w * z + y * x)") [ - proof_step 0 0 "intros" - (.success (.some 1) #[]), - proof_step 1 0 "simp [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm, Nat.mul_comm, Nat.mul_assoc, Nat.mul_left_comm] at *" - (.success (.some 2) #[]), - proof_step 2 0 "assumption" - (.success .none #[]) + --let .failure messages ← state1.tacticOn 0 tactic | addTest $ assertUnreachable s!"{tactic} should fail" + --let message := s!":0:31: error: don't know how to synthesize placeholder\ncontext:\np q r : Prop\nh : p → q\n⊢ p ∧ r\n" + --checkEq s!"{tactic} fails" messages #[message] + +def suite (env: Environment): List (String × IO LSpec.TestSeq) := + let tests := [ + ("identity", test_identity), + ("Nat.add_comm", test_nat_add_comm false), + ("Nat.add_comm manual", test_nat_add_comm true), + ("Nat.add_comm delta", test_delta_variable), + ("arithmetic", test_arith), + ("Or.comm", test_or_comm), + ("conv", test_conv), + ("calc", test_calc), + ("Nat.zero_add", test_nat_zero_add), + ("Nat.zero_add alt", test_nat_zero_add_alt), + ("tactic failure with unresolved goals", test_tactic_failure_unresolved_goals), + ("tactic failure with synthesize placeholder", test_tactic_failure_synthesize_placeholder), ] + tests.map (fun (name, test) => (name, proofRunner env test)) -def test_proofs : IO LSpec.TestSeq := do - let env: Lean.Environment ← Lean.importModules - (imports := ["Init"].map (λ str => { module := str_to_name str, runtimeOnly := false })) - (opts := {}) - (trustLevel := 1) - return LSpec.group "Proofs" $ - (LSpec.group "Nat.add_comm" $ (← proof_nat_add_comm env)) ++ - (LSpec.group "Nat.add_comm manual" $ (← proof_nat_add_comm_manual env)) ++ - (LSpec.group "Or.comm" $ (← proof_or_comm env)) ++ - (LSpec.group "Arithmetic 1" $ (← proof_arith_1 env)) - -end Pantograph.Test +end Pantograph.Test.Proofs diff --git a/Test/Serial.lean b/Test/Serial.lean index febf489..fcdc155 100644 --- a/Test/Serial.lean +++ b/Test/Serial.lean @@ -1,43 +1,109 @@ import LSpec -import Pantograph.Serial -import Pantograph.Symbols +import Test.Common +import Lean +import Pantograph.Library -namespace Pantograph.Test - -open Pantograph open Lean -deriving instance Repr, DecidableEq for BoundExpression +namespace Pantograph.Test.Serial -def test_expr_to_binder (env: Environment): IO LSpec.TestSeq := do - let cases: List (String × BoundExpression) := [ - ("Nat.add_comm", { binders := #[("n", "Nat"), ("m", "Nat")], target := "n + m = m + n" }), - ("Nat.le_of_succ_le", { binders := #[("n", "Nat"), ("m", "Nat"), ("h", "Nat.succ n ≤ m")], target := "n ≤ m" }) - ] - let coreM := cases.foldlM (λ suites (symbol, target) => do - let env ← MonadEnv.getEnv - let expr := str_to_name symbol |> env.find? |>.get! |>.type - let test := LSpec.check symbol ((← type_expr_to_bound expr) = target) - return LSpec.TestSeq.append suites test) LSpec.TestSeq.done |>.run' - let coreContext: Core.Context := { - currNamespace := str_to_name "Aniva", - openDecls := [], -- No 'open' directives needed - fileName := "", - fileMap := { source := "", positions := #[0], lines := #[1] } +def tempPath : IO System.FilePath := do + Prod.snd <$> IO.FS.createTempFile + +structure MultiState where + coreContext : Core.Context + env: Environment + +abbrev TestM := TestT $ StateRefT MultiState $ IO + +instance : MonadEnv TestM where + getEnv := return (← getThe MultiState).env + modifyEnv f := do modifyThe MultiState fun s => { s with env := f s.env } + +def runCoreM { α } (state : Core.State) (testCoreM : TestT CoreM α) : TestM (α × Core.State) := do + let multiState ← getThe MultiState + let coreM := runTestWithResult testCoreM + match ← (coreM.run multiState.coreContext state).toBaseIO with + | .error e => do + throw $ .userError $ ← e.toMessageData.toString + | .ok ((a, tests), state') => do + set $ (← getThe LSpec.TestSeq) ++ tests + return (a, state') + +def test_environment_pickling : TestM Unit := do + let coreSrc : Core.State := { env := ← getEnv } + let coreDst : Core.State := { env := ← getEnv } + + let name := `mystery + let envPicklePath ← tempPath + let ((), _) ← runCoreM coreSrc do + let type: Expr := .forallE `p (.sort 0) (.forallE `h (.bvar 0) (.bvar 1) .default) .default + let value: Expr := .lam `p (.sort 0) (.lam `h (.bvar 0) (.bvar 0) .default) .default + let c := Lean.Declaration.defnDecl <| Lean.mkDefinitionValEx + (name := name) + (levelParams := []) + (type := type) + (value := value) + (hints := Lean.mkReducibilityHintsRegularEx 1) + (safety := Lean.DefinitionSafety.safe) + (all := []) + let env' ← match (← getEnv).addDecl (← getOptions) c with + | .error e => do + let error ← (e.toMessageData (← getOptions)).toString + throwError error + | .ok env' => pure env' + environmentPickle env' envPicklePath + + let _ ← runCoreM coreDst do + let (env', _) ← environmentUnpickle envPicklePath + checkTrue s!"Has symbol {name}" (env'.find? name).isSome + let anotherName := `mystery2 + checkTrue s!"Doesn't have symbol {anotherName}" (env'.find? anotherName).isNone + + IO.FS.removeFile envPicklePath + +def test_goal_state_pickling_simple : TestM Unit := do + let coreSrc : Core.State := { env := ← getEnv } + let coreDst : Core.State := { env := ← getEnv } + let statePath ← tempPath + + let type: Expr := .forallE `p (.sort 0) (.forallE `h (.bvar 0) (.bvar 1) .default) .default + let stateGenerate : MetaM GoalState := runTermElabMInMeta do + GoalState.create type + + let ((), _) ← runCoreM coreSrc do + let state ← stateGenerate.run' + goalStatePickle state statePath + + let ((), _) ← runCoreM coreDst do + let (goalState, _) ← goalStateUnpickle statePath (← getEnv) + let metaM : MetaM (List Expr) := do + goalState.goals.mapM λ goal => goalState.withContext goal goal.getType + let types ← metaM.run' + checkTrue "Goals" $ types[0]!.equal type + + IO.FS.removeFile statePath + +structure Test where + name : String + routine: TestM Unit + +protected def Test.run (test: Test) (env: Lean.Environment) : IO LSpec.TestSeq := do + -- Create the state + let state : MultiState := { + coreContext := ← createCoreContext #[], + env, } - match ← (coreM.run' coreContext { env := env }).toBaseIO with - | .error exception => - return LSpec.test "Exception" (s!"internal exception #{← exception.toMessageData.toString}" = "") - | .ok a => return a + match ← ((runTest $ test.routine).run' state).toBaseIO with + | .ok e => return e + | .error e => + return LSpec.check s!"Emitted exception: {e.toString}" (e.toString == "") -def test_serial: IO LSpec.TestSeq := do - let env: Environment ← importModules - (imports := ["Init"].map (λ str => { module := str_to_name str, runtimeOnly := false })) - (opts := {}) - (trustLevel := 1) +def suite (env : Lean.Environment): List (String × IO LSpec.TestSeq) := + let tests: List Test := [ + { name := "environment_pickling", routine := test_environment_pickling, }, + { name := "goal_state_pickling_simple", routine := test_goal_state_pickling_simple, }, + ] + tests.map (fun test => (test.name, test.run env)) - return LSpec.group "Serialisation" $ - (LSpec.group "Expression binder" (← test_expr_to_binder env)) ++ - LSpec.test "Symbol parsing" (Name.str (.str (.str .anonymous "Lean") "Meta") "run" = Pantograph.str_to_name "Lean.Meta.run") - -end Pantograph.Test +end Pantograph.Test.Serial diff --git a/Test/Tactic.lean b/Test/Tactic.lean new file mode 100644 index 0000000..3cb0e40 --- /dev/null +++ b/Test/Tactic.lean @@ -0,0 +1,4 @@ +import Test.Tactic.Congruence +import Test.Tactic.MotivatedApply +import Test.Tactic.NoConfuse +import Test.Tactic.Prograde diff --git a/Test/Tactic/Congruence.lean b/Test/Tactic/Congruence.lean new file mode 100644 index 0000000..180c2f4 --- /dev/null +++ b/Test/Tactic/Congruence.lean @@ -0,0 +1,88 @@ +import LSpec +import Lean +import Test.Common + +open Lean +open Pantograph + +namespace Pantograph.Test.Tactic.Congruence + +def test_congr_arg_list : TestT Elab.TermElabM Unit := do + let expr := "λ {α} (l1 l2 : List α) (h: l1 = l2) => l1.reverse = l2.reverse" + let expr ← parseSentence expr + Meta.lambdaTelescope expr $ λ _ body => do + let target ← Meta.mkFreshExprSyntheticOpaqueMVar body + let newGoals ← runTacticOnMVar Tactic.evalCongruenceArg target.mvarId! + addTest $ LSpec.check "goals" ((← newGoals.mapM (λ x => mvarUserNameAndType x)) = + [ + (`α, "Sort ?u.30"), + (`a₁, "?α"), + (`a₂, "?α"), + (`f, "?α → List α"), + (`h, "?a₁ = ?a₂"), + (`conduit, "(?f ?a₁ = ?f ?a₂) = (l1.reverse = l2.reverse)"), + ]) + let f := newGoals.get! 3 + let h := newGoals.get! 4 + let c := newGoals.get! 5 + let results ← Meta.withAssignableSyntheticOpaque do f.apply (← parseSentence "List.reverse") + addTest $ LSpec.check "apply" (results.length = 0) + addTest $ LSpec.check "h" ((← exprToStr $ ← h.getType) = "?a₁ = ?a₂") + addTest $ LSpec.check "conduit" ((← exprToStr $ ← c.getType) = "(?a₁.reverse = ?a₂.reverse) = (l1.reverse = l2.reverse)") +def test_congr_arg : TestT Elab.TermElabM Unit := do + let expr := "λ (n m: Nat) (h: n = m) => n * n = m * m" + let expr ← parseSentence expr + Meta.lambdaTelescope expr $ λ _ body => do + let target ← Meta.mkFreshExprSyntheticOpaqueMVar body + let newGoals ← runTacticOnMVar Tactic.evalCongruenceArg target.mvarId! + addTest $ LSpec.check "goals" ((← newGoals.mapM (λ x => mvarUserNameAndType x)) = + [ + (`α, "Sort ?u.70"), + (`a₁, "?α"), + (`a₂, "?α"), + (`f, "?α → Nat"), + (`h, "?a₁ = ?a₂"), + (`conduit, "(?f ?a₁ = ?f ?a₂) = (n * n = m * m)"), + ]) +def test_congr_fun : TestT Elab.TermElabM Unit := do + let expr := "λ (n m: Nat) => (n + m) + (n + m) = (n + m) * 2" + let expr ← parseSentence expr + Meta.lambdaTelescope expr $ λ _ body => do + let target ← Meta.mkFreshExprSyntheticOpaqueMVar body + let newGoals ← runTacticOnMVar Tactic.evalCongruenceFun target.mvarId! + addTest $ LSpec.check "goals" ((← newGoals.mapM (λ x => mvarUserNameAndType x)) = + [ + (`α, "Sort ?u.159"), + (`f₁, "?α → Nat"), + (`f₂, "?α → Nat"), + (`h, "?f₁ = ?f₂"), + (`a, "?α"), + (`conduit, "(?f₁ ?a = ?f₂ ?a) = (n + m + (n + m) = (n + m) * 2)"), + ]) +def test_congr : TestT Elab.TermElabM Unit := do + let expr := "λ (a b: Nat) => a = b" + let expr ← parseSentence expr + Meta.lambdaTelescope expr $ λ _ body => do + let target ← Meta.mkFreshExprSyntheticOpaqueMVar body + let newGoals ← runTacticOnMVar Tactic.evalCongruence target.mvarId! + addTest $ LSpec.check "goals" ((← newGoals.mapM (λ x => mvarUserNameAndType x)) = + [ + (`α, "Sort ?u.10"), + (`f₁, "?α → Nat"), + (`f₂, "?α → Nat"), + (`a₁, "?α"), + (`a₂, "?α"), + (`h₁, "?f₁ = ?f₂"), + (`h₂, "?a₁ = ?a₂"), + (`conduit, "(?f₁ ?a₁ = ?f₂ ?a₂) = (a = b)"), + ]) + +def suite (env: Environment): List (String × IO LSpec.TestSeq) := + [ + ("congrArg List.reverse", test_congr_arg_list), + ("congrArg", test_congr_arg), + ("congrFun", test_congr_fun), + ("congr", test_congr), + ] |>.map (λ (name, t) => (name, runTestTermElabM env t)) + +end Pantograph.Test.Tactic.Congruence diff --git a/Test/Tactic/MotivatedApply.lean b/Test/Tactic/MotivatedApply.lean new file mode 100644 index 0000000..61d7d6c --- /dev/null +++ b/Test/Tactic/MotivatedApply.lean @@ -0,0 +1,113 @@ +import LSpec +import Lean +import Test.Common + +open Lean +open Pantograph + +namespace Pantograph.Test.Tactic.MotivatedApply + +def test_type_extract : TestT Elab.TermElabM Unit := do + let recursor ← parseSentence "@Nat.brecOn" + let recursorType ← Meta.inferType recursor + addTest $ LSpec.check "recursorType" ("{motive : Nat → Sort ?u.1} → (t : Nat) → ((t : Nat) → Nat.below t → motive t) → motive t" = + (← exprToStr recursorType)) + let info ← match Tactic.getRecursorInformation recursorType with + | .some info => pure info + | .none => throwError "Failed to extract recursor info" + addTest $ LSpec.check "iMotive" (info.iMotive = 2) + let motiveType := info.getMotiveType + addTest $ LSpec.check "motiveType" ("Nat → Sort ?u.1" = + (← exprToStr motiveType)) + +def test_nat_brec_on : TestT Elab.TermElabM Unit := do + let expr := "λ (n t: Nat) => n + 0 = n" + let expr ← parseSentence expr + Meta.lambdaTelescope expr $ λ _ body => do + let recursor ← match Parser.runParserCategory + (env := ← MonadEnv.getEnv) + (catName := `term) + (input := "@Nat.brecOn") + (fileName := ← getFileName) with + | .ok syn => pure syn + | .error error => throwError "Failed to parse: {error}" + -- Apply the tactic + let target ← Meta.mkFreshExprSyntheticOpaqueMVar body + let tactic := Tactic.evalMotivatedApply recursor + let newGoals ← runTacticOnMVar tactic target.mvarId! + let test := LSpec.check "goals" ((← newGoals.mapM (λ g => do exprToStr (← g.getType))) = + [ + "Nat → Prop", + "Nat", + "∀ (t : Nat), Nat.below t → ?motive t", + "?motive ?m.67 = (n + 0 = n)", + ]) + addTest test + +def test_list_brec_on : TestT Elab.TermElabM Unit := do + let expr := "λ {α : Type} (l: List α) => l ++ [] = [] ++ l" + let expr ← parseSentence expr + Meta.lambdaTelescope expr $ λ _ body => do + let recursor ← match Parser.runParserCategory + (env := ← MonadEnv.getEnv) + (catName := `term) + (input := "@List.brecOn") + (fileName := ← getFileName) with + | .ok syn => pure syn + | .error error => throwError "Failed to parse: {error}" + -- Apply the tactic + let target ← Meta.mkFreshExprSyntheticOpaqueMVar body + let tactic := Tactic.evalMotivatedApply recursor + let newGoals ← runTacticOnMVar tactic target.mvarId! + addTest $ LSpec.check "goals" ((← newGoals.mapM (λ g => do exprToStr (← g.getType))) = + [ + "Type ?u.90", + "List ?m.92 → Prop", + "List ?m.92", + "∀ (t : List ?m.92), List.below t → ?motive t", + "?motive ?m.94 = (l ++ [] = [] ++ l)", + ]) + +def test_partial_motive_instantiation : TestT Elab.TermElabM Unit := do + let expr := "λ (n t: Nat) => n + 0 = n" + let recursor ← match Parser.runParserCategory + (env := ← MonadEnv.getEnv) + (catName := `term) + (input := "@Nat.brecOn") + (fileName := ← getFileName) with + | .ok syn => pure syn + | .error error => throwError "Failed to parse: {error}" + let expr ← parseSentence expr + Meta.lambdaTelescope expr $ λ _ body => do + -- Apply the tactic + let target ← Meta.mkFreshExprSyntheticOpaqueMVar body + let tactic := Tactic.evalMotivatedApply recursor + let newGoals ← runTacticOnMVar tactic target.mvarId! + let majorId := 67 + addTest $ (LSpec.check "goals" ((← newGoals.mapM (λ g => do exprToStr (← g.getType))) = + [ + "Nat → Prop", + "Nat", + "∀ (t : Nat), Nat.below t → ?motive t", + s!"?motive ?m.{majorId} = (n + 0 = n)", + ])) + let [motive, major, step, conduit] := newGoals | panic! "Incorrect goal number" + addTest $ (LSpec.check "goal name" (major.name.toString = s!"_uniq.{majorId}")) + + -- Assign motive to `λ x => x + _` + let motive_assign ← parseSentence "λ (x: Nat) => @Nat.add x + 0 = _" + motive.assign motive_assign + + addTest $ ← conduit.withContext do + let t := toString (← Meta.ppExpr $ ← conduit.getType) + return LSpec.check "conduit" (t = s!"(?m.{majorId}.add + 0 = ?m.138 ?m.{majorId}) = (n + 0 = n)") + +def suite (env: Environment): List (String × IO LSpec.TestSeq) := + [ + ("type_extract", test_type_extract), + ("Nat.brecOn", test_nat_brec_on), + ("List.brecOn", test_list_brec_on), + ("Nat.brecOn partial motive instantiation", test_partial_motive_instantiation), + ] |>.map (λ (name, t) => (name, runTestTermElabM env t)) + +end Pantograph.Test.Tactic.MotivatedApply diff --git a/Test/Tactic/NoConfuse.lean b/Test/Tactic/NoConfuse.lean new file mode 100644 index 0000000..93f0606 --- /dev/null +++ b/Test/Tactic/NoConfuse.lean @@ -0,0 +1,72 @@ +import LSpec +import Lean +import Test.Common + +open Lean +open Pantograph + +namespace Pantograph.Test.Tactic.NoConfuse + +def test_nat : TestT Elab.TermElabM Unit := do + let expr := "λ (n: Nat) (h: 0 = n + 1) => False" + let expr ← parseSentence expr + Meta.lambdaTelescope expr $ λ _ body => do + let recursor ← match Parser.runParserCategory + (env := ← MonadEnv.getEnv) + (catName := `term) + (input := "h") + (fileName := ← getFileName) with + | .ok syn => pure syn + | .error error => throwError "Failed to parse: {error}" + -- Apply the tactic + let target ← Meta.mkFreshExprSyntheticOpaqueMVar body + let tactic := Tactic.evalNoConfuse recursor + let newGoals ← runTacticOnMVar tactic target.mvarId! + addTest $ LSpec.check "goals" ((← newGoals.mapM (λ g => do exprToStr (← g.getType))) = []) + +def test_nat_fail : TestT Elab.TermElabM Unit := do + let expr := "λ (n: Nat) (h: n = n) => False" + let expr ← parseSentence expr + Meta.lambdaTelescope expr $ λ _ body => do + let recursor ← match Parser.runParserCategory + (env := ← MonadEnv.getEnv) + (catName := `term) + (input := "h") + (fileName := ← getFileName) with + | .ok syn => pure syn + | .error error => throwError "Failed to parse: {error}" + -- Apply the tactic + let target ← Meta.mkFreshExprSyntheticOpaqueMVar body + try + let tactic := Tactic.evalNoConfuse recursor + let _ ← runTacticOnMVar tactic target.mvarId! + addTest $ assertUnreachable "Tactic should fail" + catch _ => + addTest $ LSpec.check "Tactic should fail" true + +def test_list : TestT Elab.TermElabM Unit := do + let expr := "λ (l: List Nat) (h: [] = 1 :: l) => False" + let expr ← parseSentence expr + Meta.lambdaTelescope expr $ λ _ body => do + let recursor ← match Parser.runParserCategory + (env := ← MonadEnv.getEnv) + (catName := `term) + (input := "h") + (fileName := ← getFileName) with + | .ok syn => pure syn + | .error error => throwError "Failed to parse: {error}" + -- Apply the tactic + let target ← Meta.mkFreshExprSyntheticOpaqueMVar body + let tactic := Tactic.evalNoConfuse recursor + let newGoals ← runTacticOnMVar tactic target.mvarId! + addTest $ LSpec.check "goals" + ((← newGoals.mapM (λ g => do exprToStr (← g.getType))) = []) + +def suite (env: Environment): List (String × IO LSpec.TestSeq) := + [ + ("Nat", test_nat), + ("Nat fail", test_nat_fail), + ("List", test_list), + ] |>.map (λ (name, t) => (name, runTestTermElabM env t)) + +end Pantograph.Test.Tactic.NoConfuse diff --git a/Test/Tactic/Prograde.lean b/Test/Tactic/Prograde.lean new file mode 100644 index 0000000..b3347cb --- /dev/null +++ b/Test/Tactic/Prograde.lean @@ -0,0 +1,300 @@ +import LSpec +import Lean +import Test.Common + +open Lean +open Pantograph + +namespace Pantograph.Test.Tactic.Prograde + +def test_define : TestT Elab.TermElabM Unit := do + let expr := "forall (p q : Prop) (h: p), And (Or p q) (Or p q)" + let expr ← parseSentence expr + Meta.forallTelescope expr $ λ _ body => do + let e ← match Parser.runParserCategory + (env := ← MonadEnv.getEnv) + (catName := `term) + (input := "Or.inl h") + (fileName := ← getFileName) with + | .ok syn => pure syn + | .error error => throwError "Failed to parse: {error}" + -- Apply the tactic + let goal ← Meta.mkFreshExprSyntheticOpaqueMVar body + let target: Expr := mkAnd + (mkOr (.fvar ⟨uniq 8⟩) (.fvar ⟨uniq 9⟩)) + (mkOr (.fvar ⟨uniq 8⟩) (.fvar ⟨uniq 9⟩)) + let h := .fvar ⟨uniq 8⟩ + addTest $ LSpec.test "goals before" ((← toCondensedGoal goal.mvarId!).devolatilize == { + context := #[ + cdeclOf `p (.sort 0), + cdeclOf `q (.sort 0), + cdeclOf `h h + ], + target, + }) + let tactic := Tactic.evalDefine `h2 e + let m := .mvar ⟨uniq 13⟩ + let [newGoal] ← runTacticOnMVar tactic goal.mvarId! | panic! "Incorrect goal number" + addTest $ LSpec.test "goals after" ((← toCondensedGoal newGoal).devolatilize == { + context := #[ + cdeclOf `p (.sort 0), + cdeclOf `q (.sort 0), + cdeclOf `h h, + { + userName := `h2, + type := mkOr h m, + value? := .some $ mkApp3 (mkConst `Or.inl) h m (.fvar ⟨uniq 10⟩) + } + ], + target, + }) + let .some e ← getExprMVarAssignment? goal.mvarId! | panic! "Tactic must assign" + addTest $ LSpec.test "assign" e.isLet + +def test_define_proof : TestT Elab.TermElabM Unit := do + let rootExpr ← parseSentence "∀ (p q: Prop), p → ((p ∨ q) ∨ (p ∨ q))" + let state0 ← GoalState.create rootExpr + let tactic := "intro p q h" + let state1 ← match ← state0.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check tactic ((← state1.serializeGoals).map (·.devolatilize) = + #[buildGoal [("p", "Prop"), ("q", "Prop"), ("h", "p")] "(p ∨ q) ∨ p ∨ q"]) + + let expr := "Or.inl (Or.inl h)" + let state2 ← match ← state1.tryAssign (state1.get! 0) (expr := expr) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check s!":= {expr}" ((← state2.serializeGoals).map (·.devolatilize) = + #[]) + + let evalBind := "y" + let evalExpr := "Or.inl h" + let state2 ← match ← state1.tryDefine (state1.get! 0) (binderName := evalBind) (expr := evalExpr) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check s!"eval {evalBind} := {evalExpr}" ((← state2.serializeGoals).map (·.devolatilize) = + #[{ + target := { pp? := .some "(p ∨ q) ∨ p ∨ q"}, + vars := #[ + { userName := "p", type? := .some { pp? := .some "Prop" } }, + { userName := "q", type? := .some { pp? := .some "Prop" } }, + { userName := "h", type? := .some { pp? := .some "p" } }, + { userName := "y", + type? := .some { pp? := .some "p ∨ ?m.25" }, + value? := .some { pp? := .some "Or.inl h" }, + } + ] + }]) + + let expr := "Or.inl y" + let state3 ← match ← state2.tryAssign (state2.get! 0) (expr := expr) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check s!":= {expr}" ((← state3.serializeGoals).map (·.devolatilize) = + #[]) + + addTest $ LSpec.check "(3 root)" state3.rootExpr?.isSome + +def fun_define_root_expr: ∀ (p: Prop), PProd (Nat → p) Unit → p := by + intro p x + apply x.fst + exact 5 + +def test_define_root_expr : TestT Elab.TermElabM Unit := do + --let rootExpr ← parseSentence "Nat" + --let state0 ← GoalState.create rootExpr + --let .success state1 ← state0.tacticOn (goalId := 0) "exact 5" | addTest $ assertUnreachable "exact 5" + --let .some rootExpr := state1.rootExpr? | addTest $ assertUnreachable "Root expr" + --addTest $ LSpec.check "root" ((toString $ ← Meta.ppExpr rootExpr) = "5") + let rootExpr ← parseSentence "∀ (p: Prop), PProd (Nat → p) Unit → p" + let state0 ← GoalState.create rootExpr + let tactic := "intro p x" + let .success state1 ← state0.tacticOn (goalId := 0) tactic | addTest $ assertUnreachable tactic + let binderName := `binder + let value := "x.fst" + let expr ← state1.goals[0]!.withContext $ strToTermSyntax value + let tacticM := Tactic.evalDefine binderName expr + let .success state2 ← state1.tryTacticM (state1.get! 0) tacticM | addTest $ assertUnreachable s!"define {binderName} := {value}" + let tactic := s!"apply {binderName}" + let .success state3 ← state2.tacticOn (goalId := 0) tactic | addTest $ assertUnreachable tactic + let tactic := s!"exact 5" + let .success state4 ← state3.tacticOn (goalId := 0) tactic | addTest $ assertUnreachable tactic + let .some rootExpr := state4.rootExpr? | addTest $ assertUnreachable "Root expr" + addTest $ LSpec.check "root" ((toString $ ← Meta.ppExpr rootExpr) = "fun p x =>\n let binder := x.fst;\n binder 5") + +--set_option pp.all true +--#check @PSigma (α := Prop) (β := λ (p: Prop) => p) +--def test_define_root_expr : TestT Elab.TermElabM Unit := do + +def test_have_proof : TestT Elab.TermElabM Unit := do + let rootExpr ← parseSentence "∀ (p q: Prop), p → ((p ∨ q) ∨ (p ∨ q))" + let state0 ← GoalState.create rootExpr + let tactic := "intro p q h" + let state1 ← match ← state0.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check tactic ((← state1.serializeGoals).map (·.devolatilize) = + #[buildGoal [("p", "Prop"), ("q", "Prop"), ("h", "p")] "(p ∨ q) ∨ p ∨ q"]) + + let expr := "Or.inl (Or.inl h)" + let state2 ← match ← state1.tryAssign (state1.get! 0) (expr := expr) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check s!":= {expr}" ((← state2.serializeGoals).map (·.devolatilize) = + #[]) + + let haveBind := "y" + let haveType := "p ∨ q" + let state2 ← match ← state1.tryHave (state1.get! 0) (binderName := haveBind) (type := haveType) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check s!"have {haveBind}: {haveType}" ((← state2.serializeGoals).map (·.devolatilize) = + #[ + buildGoal [("p", "Prop"), ("q", "Prop"), ("h", "p")] "p ∨ q", + buildGoal [("p", "Prop"), ("q", "Prop"), ("h", "p"), ("y", "p ∨ q")] "(p ∨ q) ∨ p ∨ q" + ]) + + let expr := "Or.inl h" + let state3 ← match ← state2.tryAssign (state2.get! 0) (expr := expr) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check s!":= {expr}" ((← state3.serializeGoals).map (·.devolatilize) = + #[]) + + let state2b ← match state3.continue state2 with + | .ok state => pure state + | .error e => do + addTest $ assertUnreachable e + return () + let expr := "Or.inl y" + let state4 ← match ← state2b.tryAssign (state2b.get! 0) (expr := expr) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check s!":= {expr}" ((← state4.serializeGoals).map (·.devolatilize) = + #[]) + + let .some rootExpr := state4.rootExpr? | addTest $ assertUnreachable "Root expr" + addTest $ LSpec.check "root" ((toString $ ← Meta.ppExpr rootExpr) = "fun p q h y => Or.inl y") + +def test_let (specialized: Bool): TestT Elab.TermElabM Unit := do + let rootExpr ← parseSentence "∀ (p q: Prop), p → ((p ∨ q) ∨ (p ∨ q))" + let state0 ← GoalState.create rootExpr + let tactic := "intro a p h" + let state1 ← match ← state0.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check tactic ((← state1.serializeGoals).map (·.devolatilize) = + #[{ + target := { pp? := .some mainTarget }, + vars := interiorVars, + }]) + + let letType := "Nat" + let expr := s!"let b: {letType} := _; _" + let result2 ← match specialized with + | true => state1.tryLet (state1.get! 0) (binderName := "b") (type := letType) + | false => state1.tryAssign (state1.get! 0) (expr := expr) + let state2 ← match result2 with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + let serializedState2 ← state2.serializeGoals + let letBindName := if specialized then "b" else "_1" + addTest $ LSpec.check expr (serializedState2.map (·.devolatilize) = + #[{ + target := { pp? := .some letType }, + vars := interiorVars, + userName? := .some letBindName + }, + { + target := { pp? := .some mainTarget }, + vars := interiorVars ++ #[{ + userName := "b", + type? := .some { pp? := .some letType }, + value? := .some { pp? := .some s!"?{letBindName}" }, + }], + userName? := if specialized then .none else .some "_2", + } + ]) + + let tactic := "exact 1" + let state3 ← match ← state2.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.check tactic ((← state3.serializeGoals).map (·.devolatilize) = #[]) + + let state3r ← match state3.continue state2 with + | .error msg => do + addTest $ assertUnreachable $ msg + return () + | .ok state => pure state + addTest $ LSpec.check "(continue)" ((← state3r.serializeGoals).map (·.devolatilize) = + #[ + { + target := { pp? := .some mainTarget }, + vars := interiorVars ++ #[{ + userName := "b", + type? := .some { pp? := .some "Nat" }, + value? := .some { pp? := .some "1" }, + }], + userName? := if specialized then .none else .some "_2", + } + ]) + + let tactic := "exact h" + match ← state3r.tacticOn (goalId := 0) (tactic := tactic) with + | .failure #[message] => + addTest $ LSpec.check tactic (message = s!"type mismatch\n h\nhas type\n a : Prop\nbut is expected to have type\n {mainTarget} : Prop") + | other => do + addTest $ assertUnreachable $ other.toString + + let tactic := "exact Or.inl (Or.inl h)" + let state4 ← match ← state3r.tacticOn (goalId := 0) (tactic := tactic) with + | .success state => pure state + | other => do + addTest $ assertUnreachable $ other.toString + return () + addTest $ LSpec.test "(4 root)" state4.rootExpr?.isSome + where + mainTarget := "(a ∨ p) ∨ a ∨ p" + interiorVars: Array Protocol.Variable := #[ + { userName := "a", type? := .some { pp? := .some "Prop" }, }, + { userName := "p", type? := .some { pp? := .some "Prop" }, }, + { userName := "h", type? := .some { pp? := .some "a" }, } + ] + +def suite (env: Environment): List (String × IO LSpec.TestSeq) := + [ + ("define", test_define), + ("define proof", test_define_proof), + ("define root expr", test_define_root_expr), + ("have proof", test_have_proof), + ("let via assign", test_let false), + ("let via tryLet", test_let true), + ] |>.map (λ (name, t) => (name, runTestTermElabM env t)) + +end Pantograph.Test.Tactic.Prograde diff --git a/Test/all.sh b/Test/all.sh deleted file mode 100755 index 9d940bd..0000000 --- a/Test/all.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/bin/bash - -lake build test && lake env build/bin/test diff --git a/doc/icon.svg b/doc/icon.svg index 394b412..eb26a19 100644 --- a/doc/icon.svg +++ b/doc/icon.svg @@ -4,17 +4,17 @@ + + + + + + + + + + + + + + + id="layer4" + inkscape:label="bg" /> + + + + + + + + + + + diff --git a/doc/rationale.md b/doc/rationale.md new file mode 100644 index 0000000..d73bb22 --- /dev/null +++ b/doc/rationale.md @@ -0,0 +1,59 @@ +# Design Rationale + +A great problem in machine learning is to use ML agents to automatically prove +mathematical theorems. This sort of proof necessarily involves *search*. +Compatibility for search is the main reason for creating Pantograph. The Lean 4 +LSP interface is not conducive to search. Pantograph is designed with this in +mind. It emphasizes the difference between 3 views of a proof: + +- **Presentation View**: The view of a written, polished proof. e.g. Mathlib and + math papers are almost always written in this form. +- **Search View**: The view of a proof exploration trajectory. This is not + explicitly supported by Lean LSP. +- **Kernel View**: The proof viewed as a set of metavariables. + +Pantograph enables proof agents to operate on the search view. + +## Name + +The name Pantograph is a pun. It means two things +- A pantograph is an instrument for copying down writing. As an agent explores + the vast proof search space, Pantograph records the current state to ensure + the proof is sound. +- A pantograph is also an equipment for an electric train. It supplies power to + a locomotive. In comparison the (relatively) simple Pantograph software powers + theorem proving projects. + +## Caveats and Limitations + +Pantograph does not exactly mimic Lean LSP's behaviour. That would not grant the +flexibility it offers. To support tree search means Pantograph has to act +differently from Lean in some times, but never at the sacrifice of soundness. + +- When Lean LSP says "don't know how to synthesize placeholder", this indicates + the human operator needs to manually move the cursor to the placeholder and + type in the correct expression. This error therefore should not halt the proof + process, and the placeholder should be turned into a goal. +- When Lean LSP says "unresolved goals", that means a proof cannot finish where + it is supposed to finish at the end of a `by` block. Pantograph will raise the + error in this case, since it indicates the termination of a proof search branch. +- `pick_goal` or `swap` will not work since they run contrary to tree search + paradigms. However, if there are tactics which perform non-trivial operations + to multiple goals at the same time, this constrain could potentially be + relaxed at a cost of great bookkeeping overhead to the user. + +Pantograph cannot perform things that are inherently constrained by Lean. These +include: + +- If a tactic loses track of metavariables, it will not be caught until the end + of the proof search. This is a bug in the tactic itself. +- Timeouts for executing tactics is not available. Maybe this will change in the + future. +- Interceptions of parsing errors generally cannot be turned into goals (e.g. + `def mystery : Nat := :=`) due to Lean's parsing system. + + +## References + +* [Pantograph Paper](https://arxiv.org/abs/2410.16429) + diff --git a/doc/repl.md b/doc/repl.md new file mode 100644 index 0000000..d332986 --- /dev/null +++ b/doc/repl.md @@ -0,0 +1,66 @@ +# REPL + +## Commands + +See `Pantograph/Protocol.lean` for a description of the parameters and return values in JSON. +* `reset`: Delete all cached expressions and proof trees +* `stat`: Display resource usage +* `expr.echo {"expr": , "type": , ["levels": []]}`: Determine the + type of an expression and format it. +* `env.catalog`: Display a list of all safe Lean symbols in the current environment +* `env.inspect {"name": , "value": }`: 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. +* `env.save { "path": }`, `env.load { "path": }`: Save/Load the + current environment to/from a file +* `options.set { key: value, ... }`: Set one or more options (not Lean options; those + have to be set via command line arguments.), for options, see `Pantograph/Protocol.lean` + + One particular option for interest for machine learning researchers is the + automatic mode (flag: `"automaticMode"`). By default it is turned on, with + all goals automatically resuming. This makes Pantograph act like a gym, + with no resumption necessary to manage your goals. +* `options.print`: Display the current set of options +* `goal.start {["name": ], ["expr": ], ["levels": []], ["copyFrom": ]}`: + Start a new proof from a given expression or symbol +* `goal.tactic {"stateId": , "goalId": , ...}`: Execute a tactic string on a + given goal. The tactic is supplied as additional key-value pairs in one of the following formats: + - `{ "tactic": }`: Execute an ordinary tactic + - `{ "expr": }`: Assign the given proof term to the current goal + - `{ "have": , "binderName": }`: Execute `have` and creates a branch goal + - `{ "calc": }`: Execute one step of a `calc` tactic. Each step must + be of the form `lhs op rhs`. An `lhs` of `_` indicates that it should be set + to the previous `rhs`. + - `{ "conv": }`: Enter or exit conversion tactic mode. In the case of + exit, the goal id is ignored. +* `goal.continue {"stateId": , ["branch": ], ["goals": ]}`: + Execute continuation/resumption + - `{ "branch": }`: Continue on branch state. The current state must have no goals. + - `{ "goals": }`: Resume the given goals +* `goal.remove {"stateIds": []}"`: Drop the goal states specified in the list +* `goal.print {"stateId": }"`: Print a goal state +* `goal.save { "id": , "path": }`, `goal.load { "path": }`: + Save/Load a goal state to/from a file. The environment is not carried with the + state. The user is responsible to ensure the sender/receiver instances share + the same environment. +* `frontend.process { ["fileName": ,] ["file": ], invocations: + , sorrys: , newConstants: }`: Executes the Lean frontend on + a file, collecting the tactic invocations (`"invocations": true`), the + sorrys and type errors into goal states (`"sorrys": true`), and new constants + (`"newConstants": true`). In the case of `sorrys`, this command additionally + outputs the position of each captured `sorry`. + +## Errors + +When an error pertaining to the execution of a command happens, the returning JSON structure is + +``` json +{ "error": "type", "desc": "description" } +``` +Common error forms: +* `command`: Indicates malformed command structure which results from either + invalid command or a malformed JSON structure that cannot be fed to an + individual command. +* `index`: Indicates an invariant maintained by the output of one command and + input of another is broken. For example, attempting to query a symbol not + existing in the library or indexing into a non-existent proof state. diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..f40dde9 --- /dev/null +++ b/flake.lock @@ -0,0 +1,142 @@ +{ + "nodes": { + "flake-parts": { + "inputs": { + "nixpkgs-lib": "nixpkgs-lib" + }, + "locked": { + "lastModified": 1730504689, + "narHash": "sha256-hgmguH29K2fvs9szpq2r3pz2/8cJd2LPS+b4tfNFCwE=", + "owner": "hercules-ci", + "repo": "flake-parts", + "rev": "506278e768c2a08bec68eb62932193e341f55c90", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "flake-parts", + "type": "github" + } + }, + "flake-parts_2": { + "inputs": { + "nixpkgs-lib": "nixpkgs-lib_2" + }, + "locked": { + "lastModified": 1727826117, + "narHash": "sha256-K5ZLCyfO/Zj9mPFldf3iwS6oZStJcU4tSpiXTMYaaL0=", + "owner": "hercules-ci", + "repo": "flake-parts", + "rev": "3d04084d54bedc3d6b8b736c70ef449225c361b1", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "flake-parts", + "type": "github" + } + }, + "lean4-nix": { + "inputs": { + "flake-parts": "flake-parts_2", + "nixpkgs": "nixpkgs" + }, + "locked": { + "lastModified": 1731711316, + "narHash": "sha256-s5u+A2/Ea9gPveB5wwVM5dWW0NST6kamDsTeovGuLEs=", + "owner": "lenianiva", + "repo": "lean4-nix", + "rev": "136fc6057c48de970579e960b62421e9c295b67d", + "type": "github" + }, + "original": { + "owner": "lenianiva", + "repo": "lean4-nix", + "type": "github" + } + }, + "lspec": { + "flake": false, + "locked": { + "lastModified": 1728279187, + "narHash": "sha256-ZMqbvCqR/gHXRuIkuo7b0Yp9N1vOQR7xnrcy/SeIBoQ=", + "owner": "argumentcomputer", + "repo": "LSpec", + "rev": "504a8cecf8da601b9466ac727aebb6b511aae4ab", + "type": "github" + }, + "original": { + "owner": "argumentcomputer", + "ref": "504a8cecf8da601b9466ac727aebb6b511aae4ab", + "repo": "LSpec", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1728500571, + "narHash": "sha256-dOymOQ3AfNI4Z337yEwHGohrVQb4yPODCW9MDUyAc4w=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "d51c28603def282a24fa034bcb007e2bcb5b5dd0", + "type": "github" + }, + "original": { + "owner": "nixos", + "ref": "nixos-24.05", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-lib": { + "locked": { + "lastModified": 1730504152, + "narHash": "sha256-lXvH/vOfb4aGYyvFmZK/HlsNsr/0CVWlwYvo2rxJk3s=", + "type": "tarball", + "url": "https://github.com/NixOS/nixpkgs/archive/cc2f28000298e1269cea6612cd06ec9979dd5d7f.tar.gz" + }, + "original": { + "type": "tarball", + "url": "https://github.com/NixOS/nixpkgs/archive/cc2f28000298e1269cea6612cd06ec9979dd5d7f.tar.gz" + } + }, + "nixpkgs-lib_2": { + "locked": { + "lastModified": 1727825735, + "narHash": "sha256-0xHYkMkeLVQAMa7gvkddbPqpxph+hDzdu1XdGPJR+Os=", + "type": "tarball", + "url": "https://github.com/NixOS/nixpkgs/archive/fb192fec7cc7a4c26d51779e9bab07ce6fa5597a.tar.gz" + }, + "original": { + "type": "tarball", + "url": "https://github.com/NixOS/nixpkgs/archive/fb192fec7cc7a4c26d51779e9bab07ce6fa5597a.tar.gz" + } + }, + "nixpkgs_2": { + "locked": { + "lastModified": 1731386116, + "narHash": "sha256-lKA770aUmjPHdTaJWnP3yQ9OI1TigenUqVC3wweqZuI=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "689fed12a013f56d4c4d3f612489634267d86529", + "type": "github" + }, + "original": { + "owner": "nixos", + "ref": "nixos-24.05", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-parts": "flake-parts", + "lean4-nix": "lean4-nix", + "lspec": "lspec", + "nixpkgs": "nixpkgs_2" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..f49a331 --- /dev/null +++ b/flake.nix @@ -0,0 +1,99 @@ +{ + description = "Pantograph"; + + inputs = { + nixpkgs.url = "github:nixos/nixpkgs/nixos-24.05"; + flake-parts.url = "github:hercules-ci/flake-parts"; + lean4-nix.url = "github:lenianiva/lean4-nix"; + lspec = { + url = "github:argumentcomputer/LSpec?ref=504a8cecf8da601b9466ac727aebb6b511aae4ab"; + flake = false; + }; + }; + + outputs = inputs @ { + self, + nixpkgs, + flake-parts, + lean4-nix, + lspec, + ... + } : flake-parts.lib.mkFlake { inherit inputs; } { + flake = { + }; + systems = [ + "aarch64-linux" + "aarch64-darwin" + "x86_64-linux" + "x86_64-darwin" + ]; + perSystem = { system, pkgs, ... }: let + pkgs = import nixpkgs { + inherit system; + overlays = [ (lean4-nix.readToolchainFile ./lean-toolchain) ]; + }; + lspecLib = pkgs.lean.buildLeanPackage { + name = "LSpec"; + roots = [ "Main" "LSpec" ]; + src = "${lspec}"; + }; + project = pkgs.lean.buildLeanPackage { + name = "Pantograph"; + roots = [ "Pantograph" ]; + src = pkgs.lib.cleanSource (pkgs.lib.cleanSourceWith { + src = ./.; + filter = path: type: + !(pkgs.lib.hasInfix "/Test/" path) && + !(pkgs.lib.hasSuffix ".md" path) && + !(pkgs.lib.hasSuffix "Repl.lean" path); + }); + }; + repl = pkgs.lean.buildLeanPackage { + name = "Repl"; + roots = [ "Main" "Repl" ]; + deps = [ project ]; + src = pkgs.lib.cleanSource (pkgs.lib.cleanSourceWith { + src = ./.; + filter = path: type: + !(pkgs.lib.hasInfix "/Test/" path) && + !(pkgs.lib.hasSuffix ".md" path); + }); + }; + test = pkgs.lean.buildLeanPackage { + name = "Test"; + # NOTE: The src directory must be ./. since that is where the import + # root begins (e.g. `import Test.Environment` and not `import + # Environment`) and thats where `lakefile.lean` resides. + roots = [ "Test.Main" ]; + deps = [ lspecLib repl ]; + src = pkgs.lib.cleanSource (pkgs.lib.cleanSourceWith { + src = ./.; + filter = path: type: + !(pkgs.lib.hasInfix "Pantograph" path); + }); + }; + in rec { + packages = { + inherit (pkgs.lean) lean lean-all; + inherit (project) sharedLib iTree; + inherit (repl) executable; + default = repl.executable; + }; + legacyPackages = { + inherit project; + leanPkgs = pkgs.lean; + }; + checks = { + test = pkgs.runCommand "test" { + buildInputs = [ test.executable pkgs.lean.lean-all ]; + } '' + #export LEAN_SRC_PATH="${./.}" + ${test.executable}/bin/test > $out + ''; + }; + devShells.default = pkgs.mkShell { + buildInputs = [ pkgs.lean.lean-all pkgs.lean.lean ]; + }; + }; + }; +} diff --git a/lake-manifest.json b/lake-manifest.json index 6a4ca4f..e1545af 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -1,33 +1,15 @@ -{"version": 4, - "packagesDir": "lake-packages", +{"version": "1.1.0", + "packagesDir": ".lake/packages", "packages": - [{"git": - {"url": "https://github.com/lurk-lab/LSpec.git", - "subDir?": null, - "rev": "88f7d23e56a061d32c7173cea5befa4b2c248b41", - "name": "LSpec", - "inputRev?": "88f7d23e56a061d32c7173cea5befa4b2c248b41"}}, - {"git": - {"url": "https://github.com/leanprover-community/mathlib4.git", - "subDir?": null, - "rev": "8e5a00a8afc8913c0584cb85f37951995275fd87", - "name": "mathlib", - "inputRev?": "8e5a00a8afc8913c0584cb85f37951995275fd87"}}, - {"git": - {"url": "https://github.com/gebner/quote4", - "subDir?": null, - "rev": "c71f94e34c1cda52eef5c93dc9da409ab2727420", - "name": "Qq", - "inputRev?": "master"}}, - {"git": - {"url": "https://github.com/JLimperg/aesop", - "subDir?": null, - "rev": "cdc00b640d0179910ebaa9c931e3b733a04b881c", - "name": "aesop", - "inputRev?": "master"}}, - {"git": - {"url": "https://github.com/leanprover/std4", - "subDir?": null, - "rev": "6006307d2ceb8743fea7e00ba0036af8654d0347", - "name": "std", - "inputRev?": "main"}}]} + [{"url": "https://github.com/lenianiva/LSpec.git", + "type": "git", + "subDir": null, + "scope": "", + "rev": "c492cecd0bc473e2f9c8b94d545d02cc0056034f", + "name": "LSpec", + "manifestFile": "lake-manifest.json", + "inputRev": "c492cecd0bc473e2f9c8b94d545d02cc0056034f", + "inherited": false, + "configFile": "lakefile.lean"}], + "name": "pantograph", + "lakeDir": ".lake"} diff --git a/lakefile.lean b/lakefile.lean index f0832e2..2aa3986 100644 --- a/lakefile.lean +++ b/lakefile.lean @@ -4,21 +4,26 @@ open Lake DSL package pantograph lean_lib Pantograph { + roots := #[`Pantograph] + defaultFacets := #[LeanLib.sharedFacet] } +lean_lib Repl { +} @[default_target] -lean_exe pantograph { +lean_exe repl { root := `Main - -- Somehow solves the native symbol not found problem + -- Solves the native symbol not found problem supportInterpreter := true } require LSpec from git - "https://github.com/lurk-lab/LSpec.git" @ "88f7d23e56a061d32c7173cea5befa4b2c248b41" + "https://github.com/lenianiva/LSpec.git" @ "c492cecd0bc473e2f9c8b94d545d02cc0056034f" lean_lib Test { } +@[test_driver] lean_exe test { root := `Test.Main - -- Somehow solves the native symbol not found problem + -- Solves the native symbol not found problem supportInterpreter := true } diff --git a/lean-toolchain b/lean-toolchain index a7041bc..8998520 100644 --- a/lean-toolchain +++ b/lean-toolchain @@ -1 +1 @@ -leanprover/lean4:nightly-2023-05-06 +leanprover/lean4:v4.12.0