module Tests.Lexer

import Quox.Lexer
import TAP


export
ToInfo Error where
  toInfo (Err reason line col char) =
    [("reason", show reason),
     ("line",   show line),
     ("col",    show col),
     ("char",   show char)]

data ExtraError
= WrongAnswer (List Token) (List Token)
| TestFailed  (List Token)

ToInfo ExtraError where
  toInfo (WrongAnswer exp got) =
    [("expected", show exp), ("received", show got)]
  toInfo (TestFailed got) =
    [("failed", show got)]


parameters (label : String) (input : String)
  acceptsSuchThat' : (List Token -> Maybe ExtraError) -> Test
  acceptsSuchThat' p = test {es = [Lexer.Error, ExtraError]} label $ do
    res <- map val <$> lex input
    case p res of
         Just err => throw 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 {es = [Lexer.Error]} label $ delay $
    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' "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"],
    rejects'     "'"
  ]
]