quox/tests/on-hold/Tests/Lexer.idr

145 lines
4 KiB
Idris
Raw Normal View History

2022-05-02 11:13:13 -04:00
module Tests.Lexer
import Quox.Lexer
import TAP
RealError = Quox.Lexer.Error
%hide Quox.Lexer.Error
2022-05-02 11:13:13 -04:00
export
ToInfo RealError where
2022-05-02 20:03:22 -04:00
toInfo (Err reason line col char) =
[("reason", show reason),
("line", show line),
("col", show col),
("char", show char)]
2022-05-02 11:13:13 -04:00
data Error
= LexerError RealError
| WrongAnswer (List Token) (List Token)
2022-05-02 20:03:22 -04:00
| TestFailed (List Token)
2022-05-02 11:13:13 -04:00
ToInfo Error where
toInfo (LexerError err) = toInfo err
2022-05-02 11:13:13 -04:00
toInfo (WrongAnswer exp got) =
[("expected", show exp), ("received", show got)]
2022-05-02 20:03:22 -04:00
toInfo (TestFailed got) =
[("failed", show got)]
2022-05-02 11:13:13 -04:00
lex' : String -> Either Error (List Token)
lex' = bimap LexerError (map val) . lex
2022-05-02 11:13:13 -04:00
parameters (label : String) (input : String)
acceptsSuchThat' : (List Token -> Maybe Error) -> Test
acceptsSuchThat' p = test label $ delay $ do
res <- bimap LexerError (map val) $ lex input
2022-05-02 11:13:13 -04:00
case p res of
Just err => throwError err
2022-05-02 11:13:13 -04:00
Nothing => pure ()
2022-05-02 20:03:22 -04:00
acceptsSuchThat : (List Token -> Bool) -> Test
2022-05-02 11:13:13 -04:00
acceptsSuchThat p = acceptsSuchThat' $ \res =>
if p res then Nothing else Just $ TestFailed res
2022-05-02 20:03:22 -04:00
acceptsWith : List Token -> Test
2022-05-02 11:13:13 -04:00
acceptsWith expect = acceptsSuchThat' $ \res =>
if res == expect then Nothing else Just $ WrongAnswer expect res
accepts : Test
accepts = acceptsSuchThat $ const True
rejects : Test
rejects = testThrows label (\case LexerError _ => True; _ => False) $ delay $
2022-05-06 15:58:32 -04:00
bimap LexerError (map val) $ lex input
2022-05-02 11:13:13 -04:00
parameters (input : String) {default False esc : Bool}
show' : String -> String
show' s = if esc then show s else "\"\{s}\""
2022-05-02 20:03:22 -04:00
acceptsWith' : List Token -> Test
2022-05-02 11:13:13 -04:00
acceptsWith' = acceptsWith (show' input) input
accepts' : Test
accepts' = accepts (show' input) input
rejects' : Test
rejects' = rejects "\{show' input} (reject)" input
tests = "lexer" :- [
"comments" :- [
acceptsWith' "" [],
acceptsWith' " \n \t\t " [] {esc = True},
acceptsWith' "-- a" [],
acceptsWith' "{- -}" [],
acceptsWith' "{--}" [],
acceptsWith' "{------}" [],
acceptsWith' "{- {- -} -}" [],
acceptsWith' "{- } -}" [],
rejects' "{-}",
rejects' "{- {- -}",
acceptsWith' "( -- comment \n )" [P LParen, P RParen] {esc = True}
],
"punctuation" :- [
acceptsWith' "({[:,]})"
2022-05-03 18:49:09 -04:00
[P LParen, P LBrace, P LSquare,
P Colon, P Comma,
2022-05-02 11:13:13 -04:00
P RSquare, P RBrace, P RParen],
acceptsWith' " ( { [ : , ] } ) "
2022-05-03 18:49:09 -04:00
[P LParen, P LBrace, P LSquare,
P Colon, P Comma,
2022-05-02 11:13:13 -04:00
P RSquare, P RBrace, P RParen],
acceptsWith' "→ ⇒ × ⊲ ∷"
[P Arrow, P DblArrow, P Times, P Triangle, P DblColon],
2022-05-02 11:13:13 -04:00
acceptsWith' "_" [P Wild]
],
"names & symbols" :- [
2022-05-02 20:03:22 -04:00
acceptsWith' "a" [Name "a"],
acceptsWith' "abc" [Name "abc"],
acceptsWith' "_a" [Name "_a"],
acceptsWith' "a_" [Name "a_"],
acceptsWith' "a_b" [Name "a_b"],
acceptsWith' "abc'" [Name "abc'"],
acceptsWith' "a'b'c''" [Name "a'b'c''"],
acceptsWith' "abc123" [Name "abc123"],
2022-05-03 18:49:09 -04:00
acceptsWith' "_1" [Name "_1"],
2022-05-02 20:03:22 -04:00
acceptsWith' "ab cd" [Name "ab", Name "cd"],
acceptsWith' "ab{--}cd" [Name "ab", Name "cd"],
acceptsWith' "'a" [Symbol "a"],
acceptsWith' "'ab" [Symbol "ab"],
acceptsWith' "'_b" [Symbol "_b"],
2022-05-06 15:35:04 -04:00
acceptsWith' "a.b.c" [Name "a", P Dot, Name "b", P Dot, Name "c"],
2022-05-03 21:11:37 -04:00
rejects' "'",
rejects' "1abc"
2022-05-03 18:49:09 -04:00
],
2022-05-04 09:30:52 -04:00
"keywords" :- [
acceptsWith' "λ" [K Lam],
2022-05-04 09:30:52 -04:00
acceptsWith' "let" [K Let],
acceptsWith' "in" [K In],
acceptsWith' "case" [K Case],
acceptsWith' "of" [K Of],
2022-05-06 15:35:04 -04:00
acceptsWith' "ω" [K Omega],
2022-05-07 15:57:10 -04:00
acceptsWith' "Π" [K Pi],
acceptsWith' "Σ" [K Sigma],
acceptsWith' "W" [K W],
acceptsWith' "WAAA" [Name "WAAA"]
2022-05-04 09:30:52 -04:00
],
2022-05-09 12:31:30 -04:00
"universes" :- [
acceptsWith' "★10" [TYPE 10],
rejects' ""
],
2022-05-03 18:49:09 -04:00
"numbers" :- [
2022-05-03 21:11:37 -04:00
acceptsWith' "0" [N Zero],
acceptsWith' "1" [N One],
acceptsWith' "2" [N $ Other 2],
acceptsWith' "69" [N $ Other 69]
2022-05-02 11:13:13 -04:00
]
]