test: Simplify monad execution

This commit is contained in:
Leni Aniva 2024-01-07 14:14:20 -08:00
parent 6e39b5ef8b
commit b29f7cb180
Signed by: aniva
GPG Key ID: 4D9B1C8D10EA4C50
2 changed files with 37 additions and 33 deletions

View File

@ -32,4 +32,25 @@ def TacticResult.toString : TacticResult → String
def assertUnreachable (message: String): LSpec.TestSeq := LSpec.check message false 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 := "<Pantograph/Test>",
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 end Pantograph

View File

@ -1,5 +1,6 @@
import LSpec import LSpec
import Pantograph.Serial import Pantograph.Serial
import Test.Common
namespace Pantograph.Test.Serial 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 expr := env.find? symbol |>.get! |>.type
let test := LSpec.check symbol.toString ((← type_expr_to_bound expr) = target) let test := LSpec.check symbol.toString ((← type_expr_to_bound expr) = target)
return LSpec.TestSeq.append suites test) LSpec.TestSeq.done |>.run' return LSpec.TestSeq.append suites test) LSpec.TestSeq.done |>.run'
let coreContext: Core.Context := { runCoreMSeq env coreM
currNamespace := Lean.Name.str .anonymous "Aniva"
openDecls := [], -- No 'open' directives needed
fileName := "<Pantograph/Test>",
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 test_sexp_of_symbol (env: Environment): IO LSpec.TestSeq := do def test_sexp_of_symbol (env: Environment): IO LSpec.TestSeq := do
let entries: List (String × String) := [ 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 expr := env.find? symbol.toName |>.get! |>.type
let test := LSpec.check symbol ((← serialize_expression_ast expr) = target) let test := LSpec.check symbol ((← serialize_expression_ast expr) = target)
return LSpec.TestSeq.append suites test) LSpec.TestSeq.done return LSpec.TestSeq.append suites test) LSpec.TestSeq.done
let coreM := metaM.run' runMetaMSeq env metaM
let coreContext: Core.Context := {
currNamespace := Lean.Name.str .anonymous "Aniva"
openDecls := [], -- No 'open' directives needed
fileName := "<Pantograph/Test>",
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 test_sexp_of_expr (env: Environment): IO LSpec.TestSeq := do def test_sexp_of_expr (env: Environment): IO LSpec.TestSeq := do
let entries: List (String × String) := [ let entries: List (String × String) := [
@ -80,17 +62,17 @@ def test_sexp_of_expr (env: Environment): IO LSpec.TestSeq := do
declName? := some "_pantograph", declName? := some "_pantograph",
errToSorry := false errToSorry := false
}) })
let coreM := metaM.run' runMetaMSeq env metaM
let coreContext: Core.Context := {
currNamespace := Lean.Name.str .anonymous "Aniva" -- Instance parsing
openDecls := [], -- No 'open' directives needed def test_instance (env: Environment): IO LSpec.TestSeq := do
fileName := "<Pantograph/Test>", let metaM: MetaM LSpec.TestSeq := do
fileMap := { source := "", positions := #[0], lines := #[1] } let env ← MonadEnv.getEnv
} let source := "λ x y: Nat => HAdd.hAdd Nat Nat Nat (instHAdd Nat instAddNat) x y"
match ← (coreM.run' coreContext { env := env }).toBaseIO with let s := syntax_from_str env source |>.toOption |>.get!
| .error exception => let expr := (← runTermElabMInMeta <| syntax_to_expr s) |>.toOption |>.get!
return LSpec.test "Exception" (s!"internal exception #{← exception.toMessageData.toString}" = "") return LSpec.TestSeq.done
| .ok a => return a runMetaMSeq env metaM
def suite: IO LSpec.TestSeq := do def suite: IO LSpec.TestSeq := do
let env: Environment ← importModules 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 "name_to_ast" test_name_to_ast) ++
(LSpec.group "Expression binder" (← test_expr_to_binder env)) ++ (LSpec.group "Expression binder" (← test_expr_to_binder env)) ++
(LSpec.group "Sexp from symbol" (← test_sexp_of_symbol 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 end Pantograph.Test.Serial