From b29f7cb180d99bd55d818d4a61ab52231c0cfbac Mon Sep 17 00:00:00 2001 From: Leni Aniva Date: Sun, 7 Jan 2024 14:14:20 -0800 Subject: [PATCH] test: Simplify monad execution --- Test/Common.lean | 21 +++++++++++++++++++++ Test/Serial.lean | 49 ++++++++++++++++-------------------------------- 2 files changed, 37 insertions(+), 33 deletions(-) diff --git a/Test/Common.lean b/Test/Common.lean index 5b74a0f..2257c7c 100644 --- a/Test/Common.lean +++ b/Test/Common.lean @@ -32,4 +32,25 @@ def TacticResult.toString : TacticResult → String def assertUnreachable (message: String): LSpec.TestSeq := LSpec.check message false +open Lean + +def runCoreMSeq (env: Environment) (coreM: CoreM LSpec.TestSeq): IO LSpec.TestSeq := do + let coreContext: Core.Context := { + currNamespace := Name.str .anonymous "Aniva" + openDecls := [], -- No 'open' directives needed + fileName := "", + fileMap := { source := "", positions := #[0], lines := #[1] } + } + 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 := { + declName? := .none, + errToSorry := false, + }) + end Pantograph diff --git a/Test/Serial.lean b/Test/Serial.lean index e502fa8..765b74e 100644 --- a/Test/Serial.lean +++ b/Test/Serial.lean @@ -1,5 +1,6 @@ import LSpec import Pantograph.Serial +import Test.Common namespace Pantograph.Test.Serial @@ -26,16 +27,7 @@ def test_expr_to_binder (env: Environment): IO LSpec.TestSeq := do let expr := env.find? symbol |>.get! |>.type let test := LSpec.check symbol.toString ((← type_expr_to_bound expr) = target) return LSpec.TestSeq.append suites test) LSpec.TestSeq.done |>.run' - let coreContext: Core.Context := { - currNamespace := Lean.Name.str .anonymous "Aniva" - openDecls := [], -- No 'open' directives needed - fileName := "", - fileMap := { source := "", positions := #[0], lines := #[1] } - } - match ← (coreM.run' coreContext { env := env }).toBaseIO with - | .error exception => - return LSpec.test "Exception" (s!"internal exception #{← exception.toMessageData.toString}" = "") - | .ok a => return a + runCoreMSeq env coreM def test_sexp_of_symbol (env: Environment): IO LSpec.TestSeq := do let entries: List (String × String) := [ @@ -53,17 +45,7 @@ def test_sexp_of_symbol (env: Environment): IO LSpec.TestSeq := do let expr := env.find? symbol.toName |>.get! |>.type let test := LSpec.check symbol ((← serialize_expression_ast expr) = target) return LSpec.TestSeq.append suites test) LSpec.TestSeq.done - let coreM := metaM.run' - let coreContext: Core.Context := { - currNamespace := Lean.Name.str .anonymous "Aniva" - openDecls := [], -- No 'open' directives needed - fileName := "", - fileMap := { source := "", positions := #[0], lines := #[1] } - } - match ← (coreM.run' coreContext { env := env }).toBaseIO with - | .error exception => - return LSpec.test "Exception" (s!"internal exception #{← exception.toMessageData.toString}" = "") - | .ok a => return a + runMetaMSeq env metaM def test_sexp_of_expr (env: Environment): IO LSpec.TestSeq := do let entries: List (String × String) := [ @@ -80,17 +62,17 @@ def test_sexp_of_expr (env: Environment): IO LSpec.TestSeq := do declName? := some "_pantograph", errToSorry := false }) - let coreM := metaM.run' - let coreContext: Core.Context := { - currNamespace := Lean.Name.str .anonymous "Aniva" - openDecls := [], -- No 'open' directives needed - fileName := "", - fileMap := { source := "", positions := #[0], lines := #[1] } - } - match ← (coreM.run' coreContext { env := env }).toBaseIO with - | .error exception => - return LSpec.test "Exception" (s!"internal exception #{← exception.toMessageData.toString}" = "") - | .ok a => return a + runMetaMSeq env metaM + +-- Instance parsing +def test_instance (env: Environment): IO LSpec.TestSeq := do + let metaM: MetaM LSpec.TestSeq := do + let env ← MonadEnv.getEnv + let source := "λ x y: Nat => HAdd.hAdd Nat Nat Nat (instHAdd Nat instAddNat) x y" + let s := syntax_from_str env source |>.toOption |>.get! + let expr := (← runTermElabMInMeta <| syntax_to_expr s) |>.toOption |>.get! + return LSpec.TestSeq.done + runMetaMSeq env metaM def suite: IO LSpec.TestSeq := do let env: Environment ← importModules @@ -102,6 +84,7 @@ def suite: IO LSpec.TestSeq := do (LSpec.group "name_to_ast" test_name_to_ast) ++ (LSpec.group "Expression binder" (← test_expr_to_binder env)) ++ (LSpec.group "Sexp from symbol" (← test_sexp_of_symbol env)) ++ - (LSpec.group "Sexp from expr" (← test_sexp_of_expr env)) + (LSpec.group "Sexp from expr" (← test_sexp_of_expr env)) ++ + (LSpec.group "Instance" (← test_instance env)) end Pantograph.Test.Serial -- 2.44.1