quox/tests/Tests/Lexer.idr

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]
  ]
]