quox/tests/Tests/FromPTerm.idr

114 lines
3.3 KiB
Idris
Raw Normal View History

2023-03-10 15:52:29 -05:00
module Tests.FromPTerm
2023-03-31 17:43:25 -04:00
import Quox.Parser.FromParser
2023-03-10 15:52:29 -05:00
import Quox.Parser
2023-03-13 14:33:09 -04:00
import TypingImpls
import Tests.Parser as TParser
2023-03-31 17:43:25 -04:00
import Quox.EffExtra
2023-05-01 21:06:25 -04:00
import TAP
import AstExtra
2023-05-14 13:58:46 -04:00
import PrettyExtra
2023-03-10 15:52:29 -05:00
2023-03-13 14:33:09 -04:00
import System.File
2023-03-10 15:52:29 -05:00
import Derive.Prelude
%language ElabReflection
%hide TParser.Failure
%hide TParser.ExpectedFail
2023-03-10 15:52:29 -05:00
public export
data Failure =
2023-03-31 17:43:25 -04:00
ParseError Parser.Error
| FromParser FromParser.Error
2023-03-10 15:52:29 -05:00
| WrongResult String
| ExpectedFail String
2023-03-13 14:33:09 -04:00
%runElab derive "FileError" [Show]
2023-03-10 15:52:29 -05:00
export
ToInfo Failure where
toInfo (ParseError err) = toInfo err
2023-03-13 14:33:09 -04:00
toInfo (FromParser err) =
[("type", "FromParserError"),
2023-05-14 13:58:46 -04:00
("got", prettyStr $ prettyError True err)]
2023-03-10 15:52:29 -05:00
toInfo (WrongResult got) =
[("type", "WrongResult"), ("got", got)]
toInfo (ExpectedFail got) =
[("type", "ExpectedFail"), ("got", got)]
parameters {c : Bool} {auto _ : Show b}
(grm : FileName -> Grammar c a)
(fromP : a -> Either FromParser.Error b)
2023-03-10 15:52:29 -05:00
(inp : String)
parameters {default (ltrim inp) label : String}
parsesWith : (b -> Bool) -> Test
parsesWith p = test label $ do
pres <- mapFst ParseError $ lexParseWith (grm "test") inp
2023-03-13 14:33:09 -04:00
res <- mapFst FromParser $ fromP pres
2023-03-10 15:52:29 -05:00
unless (p res) $ Left $ WrongResult $ show res
parses : Test
parses = parsesWith $ const True
2023-05-01 21:06:25 -04:00
%macro
parseMatch : TTImp -> Elab Test
parseMatch pat =
parsesWith <$> check `(\case ~(pat) => True; _ => False)
2023-03-10 15:52:29 -05:00
parsesAs : Eq b => b -> Test
parsesAs exp = parsesWith (== exp)
parameters {default "\{ltrim inp} # fails" label : String}
parseFails : Test
parseFails = test label $ do
pres <- mapFst ParseError $ lexParseWith (grm "test") inp
2023-03-10 15:52:29 -05:00
either (const $ Right ()) (Left . ExpectedFail . show) $ fromP pres
runFromParser : {default empty defs : Definitions} ->
Eff FromParserPure a -> Either FromParser.Error a
runFromParser = map val . fromParserPure [<] 0 defs initStack
2023-03-31 17:43:25 -04:00
2023-03-10 15:52:29 -05:00
export
tests : Test
tests = "PTerm → Term" :- [
"dimensions" :-
2023-03-31 17:43:25 -04:00
let fromPDim = runFromParser . fromPDimWith [< "𝑖", "𝑗"]
2023-03-10 15:52:29 -05:00
in [
note "dim ctx: [𝑖, 𝑗]",
2023-05-01 21:06:25 -04:00
parseMatch dim fromPDim "𝑖" `(B (VS VZ) _),
parseMatch dim fromPDim "𝑗" `(B VZ _),
2023-03-10 15:52:29 -05:00
parseFails dim fromPDim "𝑘",
2023-05-01 21:06:25 -04:00
parseMatch dim fromPDim "0" `(K Zero _),
parseMatch dim fromPDim "1" `(K One _)
2023-03-10 15:52:29 -05:00
],
"terms" :-
2023-11-02 13:14:22 -04:00
let defs = fromList [("f", mkDef GAny (^NAT) (^Zero))]
-- doesn't have to be well typed yet, just well scoped
fromPTerm = runFromParser {defs} .
2023-03-31 17:43:25 -04:00
fromPTermWith [< "𝑖", "𝑗"] [< "A", "x", "y", "z"]
2023-03-10 15:52:29 -05:00
in [
note "dim ctx: [𝑖, 𝑗]; term ctx: [A, x, y, z]",
2023-05-01 21:06:25 -04:00
parseMatch term fromPTerm "x" `(E $ B (VS $ VS VZ) _),
2023-03-31 17:43:25 -04:00
parseFails term fromPTerm "𝑖",
2023-05-21 14:09:34 -04:00
parseMatch term fromPTerm "f" `(E $ F "f" {}),
2023-05-01 21:06:25 -04:00
parseMatch term fromPTerm "λ w ⇒ w"
`(Lam (S _ $ Y $ E $ B VZ _) _),
parseMatch term fromPTerm "λ w ⇒ x"
`(Lam (S _ $ N $ E $ B (VS $ VS VZ) _) _),
parseMatch term fromPTerm "λ x ⇒ x"
`(Lam (S _ $ Y $ E $ B VZ _) _),
parseMatch term fromPTerm "λ a b ⇒ f a b"
`(Lam (S _ $ Y $
Lam (S _ $ Y $
2023-05-21 14:09:34 -04:00
E $ App (App (F "f" {}) (E $ B (VS VZ) _) _) (E $ B VZ _) _) _) _),
2023-05-01 21:06:25 -04:00
parseMatch term fromPTerm "f @𝑖" $
2023-05-21 14:09:34 -04:00
`(E $ DApp (F "f" {}) (B (VS VZ) _) _),
parseFails term fromPTerm "λ x ⇒ x¹"
],
todo "everything else"
2023-03-10 15:52:29 -05:00
]