quox/tests/Tests/Parser.idr

module Tests.Parser

import Quox.Parser
import Data.List
import Data.String
import TAP

public export
data Failure =
    LexError Lexer.Error
  | ParseError (List1 (ParsingError Token))
  | WrongResult String
  | ExpectedFail String

export
ToInfo Failure where
  toInfo (LexError err) =
    [("type", "LexError"), ("info", show err)]
  toInfo (ParseError errs) =
    ("type", "ParseError") ::
    map (bimap show show) ([1 .. length errs] `zip` toList errs)
  toInfo (WrongResult got) =
    [("type", "WrongResult"), ("got", got)]
  toInfo (ExpectedFail got) =
    [("type", "ExpectedFail"), ("got", got)]


parameters {c : Bool} {auto _ : Show a} (grm : Grammar c a)
           (inp : String)
  parameters {default (ltrim inp) label : String}
    parsesWith : (a -> Bool) -> Test
    parsesWith p = test label $ do
      toks     <- mapFst LexError $ lex inp
      (res, _) <- mapFst ParseError $ parse (grm <* eof) toks
      unless (p res) $ Left $ WrongResult $ show res

    parses : Test
    parses = parsesWith $ const True

    parsesAs : Eq a => a -> Test
    parsesAs exp = parsesWith (== exp)

  parameters {default "\{ltrim inp}  # fails" label : String}
    parseFails : Test
    parseFails = test label $ do
      toks <- mapFst LexError $ lex inp
      either (const $ Right ()) (Left . ExpectedFail . show . fst) $
        parse (grm <* eof) toks


export
tests : Test
tests = "parser" :- [
  "bound names" :- [
    parsesAs bname "_" Nothing,
    parsesAs bname "F" (Just "F"),
    parseFails bname "a.b.c"
  ],

  "names" :- [
    parsesAs name "x"
      (MakeName [<] $ UN "x"),
    parsesAs name "Data.String.length"
      (MakeName [< "Data", "String"] $ UN "length"),
    parseFails name "_"
  ],

  "dimensions" :- [
    parsesAs dim "0" (K Zero),
    parsesAs dim "1" (K One),
    parsesAs dim "ι" (V "ι"),
    parsesAs dim "(0)" (K Zero),
    parseFails dim "M.x",
    parseFails dim "_"
  ],

  "quantities" :- [
    parsesAs qty "0" Zero,
    parsesAs qty "1" One,
    parsesAs qty "ω" Any,
    parsesAs qty "#" Any,
    parsesAs qty "(#)" Any,
    parseFails qty "anythingElse",
    parseFails qty "_"
  ],

  "enum types" :- [
    parsesAs term #"{}"#          (Enum []),
    parsesAs term #"{a}"#         (Enum ["a"]),
    parsesAs term #"{a,}"#        (Enum ["a"]),
    parsesAs term #"{a.b.c.d}"#   (Enum ["a.b.c.d"]),
    parsesAs term #"{"hel lo"}"#  (Enum ["hel lo"]),
    parsesAs term #"{a, b}"#      (Enum ["a", "b"]),
    parsesAs term #"{a, b,}"#     (Enum ["a", "b"]),
    parsesAs term #"{a, b, ","}"# (Enum ["a", "b", ","]),
    parseFails term #"{,}"#
  ],

  "tags" :- [
    parsesAs term #" 'a "# (Tag "a"),
    parsesAs term #" 'abc "# (Tag "abc"),
    parsesAs term #" '"abc" "# (Tag "abc"),
    parsesAs term #" '"a b c" "# (Tag "a b c"),
    parsesAs term #" 'a b c "# (Tag "a" :@ V "b" :@ V "c")
      {label = "'a b c  # application to two args"}
  ],

  "universes" :- [
    parsesAs term "★₀" (TYPE 0),
    parsesAs term "★1" (TYPE 1),
    parsesAs term "★ 2" (TYPE 2),
    parsesAs term "Type₃" (TYPE 3),
    parsesAs term "Type4" (TYPE 4),
    parsesAs term "Type 100" (TYPE 100),
    parsesAs term "(Type 1000)" (TYPE 1000),
    parseFails term "Type",
    parseFails term "★"
  ],

  "applications" :- [
    parsesAs term "f" (V "f"),
    parsesAs term "f.x.y" (V $ MakeName [< "f", "x"] $ UN "y"),
    parsesAs term "f x" (V "f" :@ V "x"),
    parsesAs term "f x y" (V "f" :@ V "x" :@ V "y"),
    parsesAs term "(f x) y" (V "f" :@ V "x" :@ V "y"),
    parsesAs term "f (g x)" (V "f" :@ (V "g" :@ V "x")),
    parsesAs term "f (g x) y" (V "f" :@ (V "g" :@ V "x") :@ V "y"),
    parsesAs term "f @p" (V "f" :% V "p"),
    parsesAs term "f x @p y" (V "f" :@ V "x" :% V "p" :@ V "y")
  ],

  "annotations" :- [
    parsesAs term "f :: A" (V "f" :# V "A"),
    parsesAs term "f ∷ A" (V "f" :# V "A"),
    parsesAs term "f x y ∷ A B C"
      ((V "f" :@ V "x" :@ V "y") :#
       (V "A" :@ V "B" :@ V "C")),
    parsesAs term "Type 0 ∷ Type 1 ∷ Type 2"
      (TYPE 0 :# (TYPE 1 :# TYPE 2))
  ],

  "binders" :- [
    parsesAs term "(1·x : A) → B x" $
      Pi One (Just "x") (V "A") (V "B" :@ V "x"),
    parsesAs term "(1.x : A) -> B x" $
      Pi One (Just "x") (V "A") (V "B" :@ V "x"),
    parsesAs term "(ω·x : A) → B x" $
      Pi Any (Just "x") (V "A") (V "B" :@ V "x"),
    parsesAs term "(#.x : A) -> B x" $
      Pi Any (Just "x") (V "A") (V "B" :@ V "x"),
    parseFails term "(x : A) → B x",
    parseFails term "(1 ω·x : A) → B x",
    parsesAs term "(x : A) × B x" $
      Sig (Just "x") (V "A") (V "B" :@ V "x"),
    parsesAs term "(x : A) ** B x" $
      Sig (Just "x") (V "A") (V "B" :@ V "x"),
    parseFails term "(1·x : A) × B x"
  ],

  "lambdas" :- [
    parsesAs term "λ x ⇒ x" $ Lam (Just "x") (V "x"),
    parsesAs term "λ x ⇒ x" $ Lam (Just "x") (V "x"),
    parsesAs term "fun x => x" $ Lam (Just "x") (V "x"),
    parsesAs term "δ i ⇒ x @i" $ DLam (Just "i") (V "x" :% V "i"),
    parsesAs term "dfun i => x @i" $ DLam (Just "i") (V "x" :% V "i"),
    parsesAs term "λ x y z ⇒ x z y" $
      Lam (Just "x") $ Lam (Just "y") $ Lam (Just "z") $
        V "x" :@ V "z" :@ V "y"
  ],

  "pairs" :- [
    parsesAs term "(x, y)" $
      Pair (V "x") (V "y"),
    parsesAs term "(x, y, z)" $
      Pair (V "x") (Pair (V "y") (V "z")),
    parsesAs term "((x, y), z)" $
      Pair (Pair (V "x") (V "y")) (V "z"),
    parsesAs term "(f x, g @y)" $
      Pair (V "f" :@ V "x") (V "g" :% V "y"),
    parsesAs term "((x : A) × B, (0·x : C) → D)" $
      Pair (Sig (Just "x") (V "A") (V "B"))
           (Pi Zero (Just "x") (V "C") (V "D")),
    parsesAs term "(λ x ⇒ x, δ i ⇒ e @i)" $
      Pair (Lam (Just "x") (V "x"))
           (DLam (Just "i") (V "e" :% V "i")),
    parsesAs term "(x,)" (V "x"), -- i GUESS
    parseFails term "(,y)",
    parseFails term "(x,,y)"
  ],

  "equality type" :- [
    parsesAs term "Eq [i ⇒ A] s t" $
      Eq (Just "i", V "A") (V "s") (V "t"),
    parsesAs term "Eq [i ⇒ A B (C @i)] (f x y) (g y z)" $
      Eq (Just "i", V "A" :@ V "B" :@ (V "C" :% V "i"))
         (V "f" :@ V "x" :@ V "y") (V "g" :@ V "y" :@ V "z"),
    parsesAs term "Eq [A] s t" $
      Eq (Nothing, V "A") (V "s") (V "t"),
    parsesAs term "s ≡ t : A" $
      Eq (Nothing, V "A") (V "s") (V "t"),
    parsesAs term "s == t : A" $
      Eq (Nothing, V "A") (V "s") (V "t"),
    parsesAs term "f x y ≡ g y z : A B C" $
      Eq (Nothing, V "A" :@ V "B" :@ V "C")
         (V "f" :@ V "x" :@ V "y") (V "g" :@ V "y" :@ V "z"),
    parseFails term "Eq",
    parseFails term "Eq s t",
    parseFails term "s ≡ t",
    parseFails term "≡"
  ],

  "case" :- [
    parsesAs term
      "case1 f s return x ⇒ A x of { (l, r) ⇒ add l r }" $
      Case One (V "f" :@ V "s")
           (Just "x", V "A" :@ V "x")
           (CasePair (Just "l", Just "r")
                     (V "add" :@ V "l" :@ V "r")),
    parsesAs term
      "case1 f s return x ⇒ A x of { (l, r) ⇒ add l r; }" $
      Case One (V "f" :@ V "s")
           (Just "x", V "A" :@ V "x")
           (CasePair (Just "l", Just "r")
                     (V "add" :@ V "l" :@ V "r")),
    parsesAs term
      "case 1 · f s return x ⇒ A x of { (l, r) ⇒ add l r }" $
      Case One (V "f" :@ V "s")
           (Just "x", V "A" :@ V "x")
           (CasePair (Just "l", Just "r")
                     (V "add" :@ V "l" :@ V "r")),
    parsesAs term
      "case1 t return A of { 'x ⇒ p; 'y ⇒ q; 'z ⇒ r }" $
      Case One (V "t")
           (Nothing, V "A")
           (CaseEnum [("x", V "p"), ("y", V "q"), ("z", V "r")]),
    parsesAs term "caseω t return A of {}" $
      Case Any (V "t") (Nothing, V "A") (CaseEnum []),
    parsesAs term "case# t return A of {}" $
      Case Any (V "t") (Nothing, V "A") (CaseEnum [])
  ]
]