145 lines
3.9 KiB
Idris
145 lines
3.9 KiB
Idris
module Tests.Parser
|
||
|
||
import Quox.Syntax
|
||
import Quox.Parser
|
||
import Quox.Lexer
|
||
import Tests.Lexer
|
||
import Quox.Pretty
|
||
|
||
import TermImpls
|
||
import Data.SnocVect
|
||
import Text.Parser
|
||
import TAP
|
||
|
||
|
||
export
|
||
Show tok => ToInfo (ParsingError tok) where
|
||
toInfo (Error msg Nothing) = [("msg", msg)]
|
||
toInfo (Error msg (Just loc)) = [("loc", show loc), ("msg", msg)]
|
||
|
||
|
||
numberErrs : List1 Info -> Info
|
||
numberErrs (head ::: []) = head
|
||
numberErrs (head ::: tail) = go 0 (head :: tail) where
|
||
number1 : Nat -> Info -> Info
|
||
number1 n = map $ \(k, v) => (show n ++ k, v)
|
||
|
||
go : Nat -> List Info -> Info
|
||
go k [] = []
|
||
go k (x :: xs) = number1 k x ++ go (S k) xs
|
||
|
||
export
|
||
ToInfo Parser.Error where
|
||
toInfo (Lex err) = toInfo err
|
||
toInfo (Parse errs) = numberErrs $ map toInfo errs
|
||
toInfo (Leftover toks) = toInfo [("leftover", toks)]
|
||
|
||
|
||
RealError = Quox.Parser.Error
|
||
%hide Lexer.RealError
|
||
%hide Quox.Parser.Error
|
||
|
||
data Error a
|
||
= Parser RealError
|
||
| Unexpected a a
|
||
| ShouldFail a
|
||
|
||
export
|
||
Show a => ToInfo (Error a) where
|
||
toInfo (Parser err) = toInfo err
|
||
toInfo (Unexpected exp got) = toInfo $
|
||
[("expected", exp), ("received", got)]
|
||
toInfo (ShouldFail got) = toInfo [("success", got)]
|
||
|
||
|
||
parameters {c : Bool} (grm : Grammar c a) (note : String) (input : String)
|
||
parsesNote : (Show a, Eq a) => a -> Test
|
||
parsesNote exp = test "\"\{input}\"\{note}" $ delay $
|
||
case lexParseAll grm input of
|
||
Right got => if got == exp then Right ()
|
||
else Left $ Unexpected exp got
|
||
Left err => Left $ Parser err
|
||
|
||
rejectsNote : Show a => Test
|
||
rejectsNote = test "\"\{input}\"\{note} ‹reject›" $ do
|
||
case lexParseAll grm input of
|
||
Left err => Right ()
|
||
Right val => Left $ ShouldFail val
|
||
|
||
parameters {c : Bool} (grm : Grammar c a) (input : String)
|
||
parses : (Show a, Eq a) => a -> Test
|
||
parses = parsesNote grm "" input
|
||
|
||
rejects : Show a => Test
|
||
rejects = rejectsNote grm "" input
|
||
|
||
tests = "parser" :- [
|
||
"numbers" :-
|
||
let parses = parses number
|
||
in [
|
||
parses "0" 0,
|
||
parses "1" 1,
|
||
parses "1000" 1000
|
||
],
|
||
|
||
"bound vars (x, y, z | a ⊢)" :-
|
||
let grm = bound "test" {bound = [< "x", "y", "z"], avoid = [< "a"]}
|
||
parses = parses grm; rejects = rejects grm; rejectsNote = rejectsNote grm
|
||
in [
|
||
parses "x" (V 2),
|
||
parses "y" (V 1),
|
||
parses "z" (V 0),
|
||
rejects "M.x",
|
||
rejects "x.a",
|
||
rejectsNote " (avoid)" "a",
|
||
rejectsNote " (not in scope)" "c"
|
||
],
|
||
|
||
"bound or free vars (x, y, z ⊢)" :-
|
||
let parses = parses $ nameWith {bound = [< "x", "y", "z"], avoid = [<]}
|
||
in [
|
||
parses "x" (Left (V 2)),
|
||
parses "y" (Left (V 1)),
|
||
parses "z" (Left (V 0)),
|
||
parses "a" (Right (MakeName [<] (UN "a"))),
|
||
parses "a.b.c" (Right (MakeName [< "a", "b"] (UN "c"))),
|
||
parses "a . b . c" (Right (MakeName [< "a", "b"] (UN "c"))),
|
||
parses "M.x" (Right (MakeName [< "M"] (UN "x"))),
|
||
parses "x.a" (Right (MakeName [< "x"] (UN "a")))
|
||
],
|
||
|
||
"dimension (i, j | x, y, z ⊢)" :-
|
||
let grm = dimension {dvars = [< "i", "j"], tvars = [< "x", "y", "z"]}
|
||
parses = parses grm; rejects = rejects grm; rejectsNote = rejectsNote grm
|
||
in [
|
||
parses "0" (K Zero),
|
||
parses "1" (K One),
|
||
rejects "2",
|
||
parses "i" (B (V 1)),
|
||
rejectsNote " (tvar)" "x",
|
||
rejectsNote " (not in scope)" "a"
|
||
],
|
||
|
||
"terms & elims (i, j | x, y, z ⊢)" :-
|
||
let dvars = [< "i", "j"]; tvars = [< "x", "y", "z"]
|
||
tgrm = term {dvars, tvars}; egrm = elim {dvars, tvars}
|
||
tparses = parsesNote tgrm " (term)"
|
||
eparses = parsesNote egrm " (elim)"
|
||
trejects = rejectsNote tgrm " (term)"
|
||
erejects = rejectsNote egrm " (elim)"
|
||
in [
|
||
"universes" :- [
|
||
tparses "★0" (TYPE 0),
|
||
tparses "★1000" (TYPE 1000)
|
||
],
|
||
|
||
"variables" :- [
|
||
eparses "a" (F "a"),
|
||
eparses "x" (BV 2),
|
||
trejects "a",
|
||
tparses "[a]" (FT "a"),
|
||
tparses "[x]" (BVT 2)
|
||
]
|
||
]
|
||
]
|