155 lines
4.5 KiB
Idris
155 lines
4.5 KiB
Idris
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 DblColon,
|
||
P RSquare, P RBrace, P RParen],
|
||
acceptsWith' " ( { [ : , :: ] } ) "
|
||
[P LParen, P LBrace, P LSquare,
|
||
P Colon, P Comma, P DblColon,
|
||
P RSquare, P RBrace, P RParen],
|
||
acceptsWith' "-> → => ⇒ ** × << ⊲ ∷"
|
||
[P Arrow, P Arrow, P DblArrow, P DblArrow,
|
||
P Times, P Times, P Triangle, 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' "fun" [K Fun],
|
||
acceptsWith' "λ" [K Fun],
|
||
acceptsWith' "let" [K Let],
|
||
acceptsWith' "in" [K In],
|
||
acceptsWith' "case" [K Case],
|
||
acceptsWith' "of" [K Of],
|
||
acceptsWith' "ω" [K Omega],
|
||
acceptsWith' "#" [K Omega],
|
||
acceptsWith' "funk" [Name "funk"]
|
||
],
|
||
|
||
"numbers" :- [
|
||
acceptsWith' "0" [N Zero],
|
||
acceptsWith' "1" [N One],
|
||
acceptsWith' "2" [N $ Other 2],
|
||
acceptsWith' "69" [N $ Other 69],
|
||
acceptsWith' "1_000" [N $ Other 1000],
|
||
acceptsWith' "0o0" [N Zero],
|
||
acceptsWith' "0o105" [N $ Other 69],
|
||
acceptsWith' "0O0" [N Zero],
|
||
acceptsWith' "0O105" [N $ Other 69],
|
||
acceptsWith' "0x0" [N Zero],
|
||
acceptsWith' "0x45" [N $ Other 69],
|
||
acceptsWith' "0xabc" [N $ Other 2748],
|
||
acceptsWith' "0xABC" [N $ Other 2748],
|
||
acceptsWith' "0xA_BC" [N $ Other 2748],
|
||
acceptsWith' "0X0" [N Zero],
|
||
acceptsWith' "0X45" [N $ Other 69],
|
||
acceptsWith' "0XABC" [N $ Other 2748],
|
||
rejects' "1_",
|
||
rejects' "1__000"
|
||
]
|
||
]
|