quox/tests/Tests/Lexer.idr
2022-05-07 22:02:13 +02:00

140 lines
4 KiB
Idris
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

module Tests.Lexer
import Quox.Lexer
import TAP
RealError = Quox.Lexer.Error
%hide Quox.Lexer.Error
export
ToInfo RealError where
toInfo (Err reason line col char) =
[("reason", show reason),
("line", show line),
("col", show col),
("char", show char)]
data Error
= LexerError RealError
| WrongAnswer (List Token) (List Token)
| TestFailed (List Token)
ToInfo Error where
toInfo (LexerError err) = toInfo err
toInfo (WrongAnswer exp got) =
[("expected", show exp), ("received", show got)]
toInfo (TestFailed got) =
[("failed", show got)]
lex' : String -> Either Error (List Token)
lex' = bimap LexerError (map val) . lex
parameters (label : String) (input : String)
acceptsSuchThat' : (List Token -> Maybe Error) -> Test
acceptsSuchThat' p = test label $ delay $ do
res <- bimap LexerError (map val) $ lex input
case p res of
Just err => throwError err
Nothing => pure ()
acceptsSuchThat : (List Token -> Bool) -> Test
acceptsSuchThat p = acceptsSuchThat' $ \res =>
if p res then Nothing else Just $ TestFailed res
acceptsWith : List Token -> Test
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 $
bimap LexerError (map val) $ lex input
parameters (input : String) {default False esc : Bool}
show' : String -> String
show' s = if esc then show s else "\"\{s}\""
acceptsWith' : List Token -> Test
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' "({[:,]})"
[P LParen, P LBrace, P LSquare,
P Colon, P Comma,
P RSquare, P RBrace, P RParen],
acceptsWith' " ( { [ : , ] } ) "
[P LParen, P LBrace, P LSquare,
P Colon, P Comma,
P RSquare, P RBrace, P RParen],
acceptsWith' "→ ⇒ × ⊲ ∷"
[P Arrow, P DblArrow, P Times, P Triangle, P DblColon],
acceptsWith' "_" [P Wild]
],
"names & symbols" :- [
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"],
acceptsWith' "_1" [Name "_1"],
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"],
acceptsWith' "a.b.c" [Name "a", P Dot, Name "b", P Dot, Name "c"],
rejects' "'",
rejects' "1abc"
],
"keywords" :- [
acceptsWith' "λ" [K Lam],
acceptsWith' "let" [K Let],
acceptsWith' "in" [K In],
acceptsWith' "case" [K Case],
acceptsWith' "of" [K Of],
acceptsWith' "ω" [K Omega],
acceptsWith' "Π" [K Pi],
acceptsWith' "Σ" [K Sigma],
acceptsWith' "W" [K W],
acceptsWith' "" [K TYPE],
acceptsWith' "WAAA" [Name "WAAA"]
],
"numbers" :- [
acceptsWith' "0" [N Zero],
acceptsWith' "1" [N One],
acceptsWith' "2" [N $ Other 2],
acceptsWith' "69" [N $ Other 69]
]
]