module Tests.Lexer

import Quox.Name
import Quox.Parser.Lexer
import TAP


private
data Failure = LexError Lexer.Error
             | WrongLex (List Token) (List Token)
             | ExpectedFail (List Token)

private
ToInfo Failure where
  toInfo (LexError err) =
    [("type", "LexError"),
     ("info", show err)]
  toInfo (WrongLex want got) =
    [("type", "WrongLex"),
     ("want", show want),
     ("got",  show got)]
  toInfo (ExpectedFail got) =
    [("type", "ExpectedFail"),
     ("got",  show got)]


private
denewline : String -> String
denewline = pack . map (\case '\n' => '␤'; c => c) . unpack

private
lexes : String -> List Token -> Test
lexes str toks = test "｢\{denewline str}｣" $ do
  res <- bimap LexError (map val) $ lex str
  unless (toks == res) $ throwError $ WrongLex toks res

private
lexFail : String -> Test
lexFail str = test "｢\{denewline str}｣   # fails" $
  either (const $ Right ()) (Left . ExpectedFail . map val) $ lex str

export
tests : Test
tests = "lexer" :- [
  "comments" :- [
    lexes "" [],
    lexes "    " [],
    lexes "-- line comment" [],
    lexes "name -- line comment" [Name "name"],
    lexes
      """
      -- line comment
      nameBetween -- and another
      """
      [Name "nameBetween"],
    lexes "{- block comment -}" [],
    lexes "{- {- nested -} block comment -}" []
  ],

  "identifiers & keywords" :- [
    lexes "abc" [Name "abc"],
    lexes "abc def" [Name "abc", Reserved "def"],
    lexes "abc_def" [Name "abc_def"],
    lexes "abc-def" [Name "abc-def"],
    lexes "abc{-comment-}def" [Name "abc", Reserved "def"],
    lexes "λ" [Reserved "λ"],
    lexes "fun" [Reserved "λ"],
    lexes "δ" [Reserved "δ"],
    lexes "dfun" [Reserved "δ"],
    lexes "funky" [Name "funky"],
    lexes "δελτα" [Name "δελτα"],
    lexes "★★" [Name "★★"],
    lexes "Types" [Name "Types"],
    lexes "a.b.c.d.e" [Name $ MkPName [< "a","b","c","d"] "e"],
    lexes "normalïse" [Name "normalïse"],
      -- ↑ replace i + combining ¨ with precomposed ï
    lexes "map#" [Name "map#"],
    lexes "map#[" [Name "map#", Reserved "["], -- don't actually do this
    lexes "map #[" [Name "map", Reserved "#["],
    lexes "write!" [Name "write!"],
    lexes "uhh??!?!?!?" [Name "uhh??!?!?!?"],

    lexFail "abc.fun.ghi",
    lexFail "abc.λ.ghi",
    lexFail "abc.ω.ghi",

    lexes "+" [Name "+"],
    lexes "*" [Name "*"],
    lexes "**" [Reserved "×"],
    lexes "***" [Name "***"],
    lexes "+**" [Name "+**"],
    lexes "+#" [Name "+#"],
    lexes "+.+.+" [Name $ MkPName [< "+", "+"] "+"],
    lexes "a.+" [Name $ MkPName [< "a"] "+"],
    lexes "+.a" [Name $ MkPName [< "+"] "a"],

    lexes "+a" [Name "+", Name "a"],

    lexes "x." [Name "x", Reserved "."],
    lexes "&." [Name "&", Reserved "."],
    lexes ".x" [Reserved ".", Name "x"],
    lexes "a.b.c." [Name $ MkPName [< "a", "b"] "c", Reserved "."],

    lexes "case" [Reserved "case"],
    lexes "caseω" [Reserved "caseω"],
    lexes "case#" [Reserved "caseω"],
    lexes "case1" [Reserved "case1"],
    lexes "case0" [Reserved "case0"],
    lexes "case##" [Name "case##"],

    lexes "let" [Reserved "let"],
    lexes "letω" [Reserved "letω"],
    lexes "let#" [Reserved "letω"],
    lexes "let1" [Reserved "let1"],
    lexes "let0" [Reserved "let0"],
    lexes "let##" [Name "let##"],

    lexes "_" [Reserved "_"],
    lexes "_a" [Name "_a"],
    lexes "a_" [Name "a_"],

    lexes "a'" [Name "a'"],
    lexes "+'" [Name "+'"],

    lexes "a₁" [Name "a₁"],
    lexes "a⁰" [Name "a", Sup 0],
    lexes "a^0" [Name "a", Sup 0],

    lexes "0.x" [Nat 0, Reserved ".", Name "x"],
    lexes "1.x" [Nat 1, Reserved ".", Name "x"],
    lexes "ω.x" [Reserved "ω", Reserved ".", Name "x"],
    lexes "#.x" [Reserved "ω", Reserved ".", Name "x"]
  ],

  "syntax characters" :- [
    lexes "()" [Reserved "(", Reserved ")"],
    lexes "(a)" [Reserved "(", Name "a", Reserved ")"],
    lexFail "(^)",
    lexes "{a,b}"
      [Reserved "{", Name "a", Reserved ",", Name "b", Reserved "}"],
    lexes "{+,-}"
      [Reserved "{", Name "+", Reserved ",", Name "-", Reserved "}"]
  ],

  "tags" :- [
    lexes #" 'a "# [Tag "a"],
    lexes #" 'abc "# [Tag "abc"],
    lexes #" '+ "# [Tag "+"],
    lexes #" '$$$ "# [Tag "$$$"],
    lexes #" 'tag.with.dots "# [Tag "tag.with.dots"],
    lexes #" '"multi word tag" "# [Tag "multi word tag"],
    lexes #" '"" "# [Tag ""],
    lexFail #" ' "#,
    lexFail #" '' "#
  ],

  "strings" :- [
    lexes   #" ""          "# [Str ""],
    lexes   #" "abc"       "# [Str "abc"],
    lexes   #" "\""        "# [Str "\""],
    lexes   #" "\\"        "# [Str "\\"],
    lexes   #" "\\\""      "# [Str "\\\""],
    lexes   #" "\t"        "# [Str "\t"],
    lexes   #" "\n"        "# [Str "\n"],
    lexes   #" "🐉"        "# [Str "🐉"],
    lexes   #" "\x1f409;"  "# [Str "🐉"],
    lexFail #" "\q"        "#,
    lexFail #" "\"         "#
  ],

  "naturals" :- [
    lexes   "0"           [Nat 0],
    lexes   "123"         [Nat 123],
    lexes   "69_420"      [Nat 69420],
    lexes   "0x123"       [Nat 0x123],
    lexes   "0xbeef"      [Nat 0xbeef],
    lexes   "0xBEEF"      [Nat 0xBEEF],
    lexes   "0XBEEF"      [Nat 0xBEEF],
    lexes   "0xbaba_baba" [Nat 0xbabababa],
    lexFail "123abc",
    lexFail "0x123abcghi"
  ],

  "universes" :- [
    lexes "Type0" [TYPE 0],
    lexes "Type⁰" [Reserved "★", Sup 0],
    lexes "Type9999999" [TYPE 9999999],
    lexes "★⁰" [Reserved "★", Sup 0],
    lexes "★⁶⁹" [Reserved "★", Sup 69],
    lexes "★4" [TYPE 4],
    lexes "Type" [Reserved "★"],
    lexes "★" [Reserved "★"]
  ]
]