2023-11-04 15:00:51 -07:00
|
|
|
|
import Pantograph.Goal
|
2024-03-28 00:06:35 -07:00
|
|
|
|
import Pantograph.Library
|
|
|
|
|
import Pantograph.Protocol
|
2024-03-28 18:56:42 -07:00
|
|
|
|
import Lean
|
2023-11-04 15:00:51 -07:00
|
|
|
|
import LSpec
|
2023-10-25 22:18:59 -07:00
|
|
|
|
|
2024-03-28 18:56:42 -07:00
|
|
|
|
open Lean
|
|
|
|
|
|
2023-10-25 22:18:59 -07:00
|
|
|
|
namespace Pantograph
|
|
|
|
|
|
2024-04-06 14:07:13 -07:00
|
|
|
|
-- Auxiliary functions
|
2023-10-25 22:18:59 -07:00
|
|
|
|
namespace Protocol
|
|
|
|
|
/-- Set internal names to "" -/
|
|
|
|
|
def Goal.devolatilize (goal: Goal): Goal :=
|
|
|
|
|
{
|
|
|
|
|
goal with
|
2023-10-30 14:44:06 -07:00
|
|
|
|
name := "",
|
2023-10-25 22:18:59 -07:00
|
|
|
|
vars := goal.vars.map removeInternalAux,
|
|
|
|
|
}
|
|
|
|
|
where removeInternalAux (v: Variable): Variable :=
|
|
|
|
|
{
|
|
|
|
|
v with
|
|
|
|
|
name := ""
|
|
|
|
|
}
|
2023-11-04 15:00:51 -07:00
|
|
|
|
deriving instance DecidableEq, Repr for Expression
|
|
|
|
|
deriving instance DecidableEq, Repr for Variable
|
|
|
|
|
deriving instance DecidableEq, Repr for Goal
|
2024-03-31 16:43:30 -07:00
|
|
|
|
deriving instance DecidableEq, Repr for ExprEchoResult
|
|
|
|
|
deriving instance DecidableEq, Repr for InteractionError
|
|
|
|
|
deriving instance DecidableEq, Repr for Option
|
2023-10-25 22:18:59 -07:00
|
|
|
|
end Protocol
|
|
|
|
|
|
2023-11-04 15:00:51 -07:00
|
|
|
|
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}"
|
|
|
|
|
| .indexError index => s!".indexError {index}"
|
|
|
|
|
|
2024-04-06 14:07:13 -07:00
|
|
|
|
namespace Test
|
2023-11-04 15:00:51 -07:00
|
|
|
|
|
2024-04-06 14:07:13 -07:00
|
|
|
|
def expectationFailure (desc: String) (error: String): LSpec.TestSeq := LSpec.test desc (LSpec.ExpectationFailure "ok _" error)
|
|
|
|
|
|
|
|
|
|
-- Test running infrastructure
|
|
|
|
|
|
|
|
|
|
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
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
def assertUnreachable (message: String): LSpec.TestSeq := LSpec.check message false
|
2024-01-07 14:14:20 -08:00
|
|
|
|
|
2024-03-31 16:43:30 -07:00
|
|
|
|
def runCoreMSeq (env: Environment) (coreM: CoreM LSpec.TestSeq) (options: Array String := #[]): IO LSpec.TestSeq := do
|
|
|
|
|
let coreContext: Core.Context ← createCoreContext options
|
2024-01-07 14:14:20 -08:00
|
|
|
|
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,
|
|
|
|
|
})
|
|
|
|
|
|
2024-03-28 00:06:35 -07:00
|
|
|
|
def defaultTermElabMContext: Lean.Elab.Term.Context := {
|
|
|
|
|
declName? := some "_pantograph".toName,
|
|
|
|
|
errToSorry := false
|
|
|
|
|
}
|
2024-04-06 14:07:13 -07:00
|
|
|
|
end Test
|
2024-03-28 00:06:35 -07:00
|
|
|
|
|
2023-10-25 22:18:59 -07:00
|
|
|
|
end Pantograph
|