2022-05-02 11:13:13 -04:00
|
|
|
|
module Tests.Lexer
|
|
|
|
|
|
|
|
|
|
import Quox.Lexer
|
|
|
|
|
import TAP
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
export
|
|
|
|
|
ToInfo Error 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 ExtraError
|
2022-05-02 20:03:22 -04:00
|
|
|
|
= WrongAnswer (List Token) (List Token)
|
|
|
|
|
| TestFailed (List Token)
|
2022-05-02 11:13:13 -04:00
|
|
|
|
|
|
|
|
|
ToInfo ExtraError where
|
|
|
|
|
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
|
|
|
|
|
|
|
|
|
|
|
|
|
|
parameters (label : String) (input : String)
|
2022-05-02 20:03:22 -04:00
|
|
|
|
acceptsSuchThat' : (List Token -> Maybe ExtraError) -> Test
|
2022-05-02 11:13:13 -04:00
|
|
|
|
acceptsSuchThat' p = test {es = [Lexer.Error, ExtraError]} label $ do
|
2022-05-02 20:03:22 -04:00
|
|
|
|
res <- map val <$> lex input
|
2022-05-02 11:13:13 -04:00
|
|
|
|
case p res of
|
|
|
|
|
Just err => throw err
|
|
|
|
|
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 {es = [Lexer.Error]} label $ delay $
|
2022-05-02 20:03:22 -04:00
|
|
|
|
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' "({[:,::]})"
|
|
|
|
|
[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" :- [
|
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"],
|
|
|
|
|
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-02 11:13:13 -04:00
|
|
|
|
rejects' "'"
|
|
|
|
|
]
|
|
|
|
|
]
|