module Tests.Parser

import Quox.Syntax
import Quox.Parser
import Quox.Lexer
import Tests.Lexer
import Quox.Pretty

import TermImpls
import Data.SnocVect
import Text.Parser
import TAP


export
Show tok => ToInfo (ParsingError tok) where
  toInfo (Error msg Nothing)    = [("msg", msg)]
  toInfo (Error msg (Just loc)) = [("loc", show loc), ("msg", msg)]


numberErrs : List1 Info -> Info
numberErrs (head ::: [])   = head
numberErrs (head ::: tail) = go 0 (head :: tail) where
  number1 : Nat -> Info -> Info
  number1 n = map $ \(k, v) => (show n ++ k, v)

  go : Nat -> List Info -> Info
  go k []        = []
  go k (x :: xs) = number1 k x ++ go (S k) xs

export
ToInfo Parser.Error where
  toInfo (Lex      err)  = toInfo err
  toInfo (Parse    errs) = numberErrs $ map toInfo errs
  toInfo (Leftover toks) = toInfo [("leftover", toks)]


RealError = Quox.Parser.Error
%hide Lexer.RealError
%hide Quox.Parser.Error

data Error a
= Parser RealError
| Unexpected a a
| ShouldFail a

export
Show a => ToInfo (Error a) where
  toInfo (Parser err) = toInfo err
  toInfo (Unexpected exp got) = toInfo $
    [("expected", exp), ("received", got)]
  toInfo (ShouldFail got) = toInfo [("success", got)]


parameters {c : Bool} (grm : Grammar c a) (note : String) (input : String)
  parsesNote : (Show a, Eq a) => a -> Test
  parsesNote exp = test "\"\{input}\"\{note}" $ delay $
    case lexParseAll grm input of
         Right got => if got == exp then Right ()
                                    else Left $ Unexpected exp got
         Left  err => Left $ Parser err

  rejectsNote : Show a => Test
  rejectsNote = test "\"\{input}\"\{note} ‹reject›" $ do
    case lexParseAll grm input of
         Left  err => Right ()
         Right val => Left $ ShouldFail val

parameters {c : Bool} (grm : Grammar c a) (input : String)
  parses : (Show a, Eq a) => a -> Test
  parses = parsesNote grm "" input

  rejects : Show a => Test
  rejects = rejectsNote grm "" input

tests = "parser" :- [
  "numbers" :-
  let parses = parses number
  in [
    parses "0"    0,
    parses "1"    1,
    parses "1000" 1000
  ],

  "bound vars (x, y, z | a ⊢)" :-
  let grm = bound "test" {bound = [< "x", "y", "z"], avoid = [< "a"]}
      parses = parses grm; rejects = rejects grm; rejectsNote = rejectsNote grm
  in [
    parses  "x" (V 2),
    parses  "y" (V 1),
    parses  "z" (V 0),
    rejects "M.x",
    rejects "x.a",
    rejectsNote " (avoid)"        "a",
    rejectsNote " (not in scope)" "c"
  ],

  "bound or free vars (x, y, z ⊢)" :-
  let parses = parses $ nameWith {bound = [< "x", "y", "z"], avoid = [<]}
  in [
    parses "x"         (Left (V 2)),
    parses "y"         (Left (V 1)),
    parses "z"         (Left (V 0)),
    parses "a"         (Right (MakeName [<]          (UN "a"))),
    parses "a.b.c"     (Right (MakeName [< "a", "b"] (UN "c"))),
    parses "a . b . c" (Right (MakeName [< "a", "b"] (UN "c"))),
    parses "M.x"       (Right (MakeName [< "M"]      (UN "x"))),
    parses "x.a"       (Right (MakeName [< "x"]      (UN "a")))
  ],

  "dimension (i, j | x, y, z ⊢)" :-
  let grm = dimension {dvars = [< "i", "j"], tvars = [< "x", "y", "z"]}
      parses = parses grm; rejects = rejects grm; rejectsNote = rejectsNote grm
  in [
    parses  "0" (K Zero),
    parses  "1" (K One),
    rejects "2",
    parses  "i" (B (V 1)),
    rejectsNote " (tvar)"         "x",
    rejectsNote " (not in scope)" "a"
  ],

  "terms & elims (i, j | x, y, z ⊢)" :-
  let dvars = [< "i", "j"]; tvars = [< "x", "y", "z"]
      tgrm = term {dvars, tvars}; egrm = elim {dvars, tvars}
      tparses  = parsesNote  tgrm " (term)"
      eparses  = parsesNote  egrm " (elim)"
      trejects = rejectsNote tgrm " (term)"
      erejects = rejectsNote egrm " (elim)"
  in [
    "universes" :- [
      tparses "★0"    (TYPE 0),
      tparses "★1000" (TYPE 1000)
    ],

    "variables" :- [
      eparses  "a"   (F "a"),
      eparses  "x"   (BV 2),
      trejects "a",
      tparses  "[a]" (FT "a"),
      tparses  "[x]" (BVT 2)
    ]
  ]
]