module Tests.Typechecker

import Quox.Syntax
import Quox.Syntax.Qty.Three
import Quox.Typechecker as Lib
import public TypingImpls
import TAP


0 M : Type -> Type
M = ReaderT (Definitions Three) $ Either (Error Three)



reflTy : IsQty q => Term q d n
reflTy =
  Pi zero "A" (TYPE 0) $ TUsed $
  Pi one  "x" (BVT 0)  $ TUsed $
  Eq0 (BVT 1) (BVT 0) (BVT 0)

reflDef : IsQty q => Term q d n
reflDef = ["A","x"] :\\ ["i"] :\\% BVT 0

defGlobals : Definitions Three
defGlobals = fromList
  [("A", mkAbstract Zero $ TYPE 0),
   ("B", mkAbstract Zero $ TYPE 0),
   ("C", mkAbstract Zero $ TYPE 1),
   ("D", mkAbstract Zero $ TYPE 1),
   ("P", mkAbstract Zero $ Arr Any (FT "A") (TYPE 0)),
   ("a", mkAbstract Any  $ FT "A"),
   ("b", mkAbstract Any  $ FT "B"),
   ("f", mkAbstract Any  $ Arr One (FT "A") (FT "A")),
   ("g", mkAbstract Any  $ Arr One (FT "A") (FT "B")),
   ("p", mkAbstract Any  $ Pi One "x" (FT "A") $ TUsed $ E $ F "P" :@ BVT 0),
   ("q", mkAbstract Any  $ Pi One "x" (FT "A") $ TUsed $ E $ F "P" :@ BVT 0),
   ("refl", mkDef Any reflTy reflDef)]

parameters (label : String) (act : Lazy (M ()))
           {default defGlobals globals : Definitions Three}
  testTC : Test
  testTC = test label $ runReaderT globals act

  testTCFail : Test
  testTCFail = testThrows label (const True) $ runReaderT globals act


ctxWith : DContext d -> Context (\i => (Term Three d i, Three)) n ->
          TyContext Three d n
ctxWith dctx tqctx =
  let (tctx, qctx) = unzip tqctx in MkTyContext {dctx, tctx, qctx}

ctx : Context (\i => (Term Three 0 i, Three)) n -> TyContext Three 0 n
ctx = ctxWith DNil

inferAs : TyContext Three d n -> (sg : SQty Three) ->
          Elim Three d n -> Term Three d n -> M ()
inferAs ctx sg e ty = do
  ty' <- infer ctx sg e
  catchError
    (equalType (makeDimEq ctx.dctx) ctx.tctx ty ty'.type)
    (\_ : Error Three => throwError $ ClashT Equal (TYPE UAny) ty ty'.type)

infer_ : TyContext Three d n -> (sg : SQty Three) -> Elim Three d n -> M ()
infer_ ctx sg e = ignore $ infer ctx sg e

check_ : TyContext Three d n -> SQty Three ->
         Term Three d n -> Term Three d n -> M ()
check_ ctx sg s ty = ignore $ check ctx sg s ty

export
tests : Test
tests = "typechecker" :- [
  "universes" :- [
    testTC "0 · ★₀ ⇐ ★₁" $ check_ (ctx [<]) szero (TYPE 0) (TYPE 1),
    testTC "0 · ★₀ ⇐ ★₂" $ check_ (ctx [<]) szero (TYPE 0) (TYPE 2),
    testTC "0 · ★₀ ⇐ ★_" $ check_ (ctx [<]) szero (TYPE 0) (TYPE UAny),
    testTCFail "0 · ★₁ ⇍ ★₀" $ check_ (ctx [<]) szero (TYPE 1) (TYPE 0),
    testTCFail "0 · ★₀ ⇍ ★₀" $ check_ (ctx [<]) szero (TYPE 0) (TYPE 0),
    testTCFail "0 · ★_ ⇍ ★_" $ check_ (ctx [<]) szero (TYPE UAny) (TYPE UAny),
    testTCFail "1 · ★₀ ⇍ ★₁" $ check_ (ctx [<]) sone (TYPE 0) (TYPE 1)
  ],

  "function types" :- [
    note "A, B : ★₀;  C, D : ★₁",
    testTC "0 · A ⊸ B ⇐ ★₀" $
      check_ (ctx [<]) szero (Arr One (FT "A") (FT "B")) (TYPE 0),
    note "subtyping",
    testTC "0 · A ⊸ B ⇐ ★₁" $
      check_ (ctx [<]) szero (Arr One (FT "A") (FT "B")) (TYPE 1),
    testTC "0 · C ⊸ D ⇐ ★₁" $
      check_ (ctx [<]) szero (Arr One (FT "C") (FT "D")) (TYPE 1),
    testTCFail "0 · C ⊸ D ⇍ ★₀" $
      check_ (ctx [<]) szero (Arr One (FT "C") (FT "D")) (TYPE 0)
  ],

  "free vars" :- [
    note "A : ★₀",
    testTC "0 · A ⇒ ★₀" $
      inferAs (ctx [<]) szero (F "A") (TYPE 0),
    note "check",
    testTC "0 · A ⇐ ★₀" $
      check_ (ctx [<]) szero (FT "A") (TYPE 0),
    note "subtyping",
    testTC "0 · A ⇐ ★₁" $
      check_ (ctx [<]) szero (FT "A") (TYPE 1),
    note "(fail) runtime-relevant type",
    testTCFail "1 · A ⇏ ★₀" $
      infer_ (ctx [<]) sone (F "A"),
    note "refl : (0·A : ★₀) → (1·x : A) → (x ≡ x : A) ≔ (λ A x ⇒ λᴰ _ ⇒ x)",
    testTC "1 · refl ⇒ ⋯" $ inferAs (ctx [<]) sone (F  "refl") reflTy,
    testTC "1 · refl ⇐ ⋯" $ check_  (ctx [<]) sone (FT "refl") reflTy
  ],

  "lambda" :- [
    note "linear & unrestricted identity",
    testTC "1 · (λ x ⇒ x) ⇐ A ⊸ A" $
      check_ (ctx [<]) sone (["x"] :\\ BVT 0) (Arr One (FT "A") (FT "A")),
    testTC "1 · (λ x ⇒ x) ⇐ A → A" $
      check_ (ctx [<]) sone (["x"] :\\ BVT 0) (Arr Any (FT "A") (FT "A")),
    note "(fail) zero binding used relevantly",
    testTCFail "1 · (λ x ⇒ x) ⇍ A ⇾ A" $
      check_ (ctx [<]) sone (["x"] :\\ BVT 0) (Arr Zero (FT "A") (FT "A")),
    note "(but ok in overall erased context)",
    testTC "0 · (λ x ⇒ x) ⇐ A ⇾ A" $
      check_ (ctx [<]) szero (["x"] :\\ BVT 0) (Arr Zero (FT "A") (FT "A")),
    testTC "1 · (λ A x ⇒ refl A x) ⇐ ⋯  # (type of refl)" $
      check_ (ctx [<]) sone
        (["A", "x"] :\\ E (F "refl" :@@ [BVT 1, BVT 0]))
        reflTy,
    testTC "1 · (λ A x ⇒ λᴰ i ⇒ x) ⇐ ⋯  # (def. and type of refl)" $
      check_ (ctx [<]) sone reflDef reflTy
  ],

  "misc" :- [
    note "0·A : Type, 0·P : A → Type, ω·p : (1·x : A) → P x",
    note "⊢",
    note "1 · λ x y xy ⇒ λᴰ i ⇒ p (xy i)",
    note "  ⇐ (0·x, y : A) → (1·xy : x ≡ y) → Eq [i ⇒ P (xy i)] (p x) (p y)",
    testTC "cong" $
      check_ (ctx [<]) sone
        (["x", "y", "xy"] :\\ ["i"] :\\% E (F "p" :@ E (BV 0 :% BV 0)))
        (Pi Zero "x"  (FT "A") $ TUsed $
         Pi Zero "y"  (FT "A") $ TUsed $
         Pi One  "xy" (Eq0 (FT "A") (BVT 1) (BVT 0)) $ TUsed $
         Eq "i" (DUsed $ E $ F "P" :@ E (BV 0 :% BV 0))
                (E $ F "p" :@ BVT 2) (E $ F "p" :@ BVT 1)),
    note "0·A : Type, 0·P : ω·A → Type,",
    note "ω·p, q : (1·x : A) → P x",
    note "⊢",
    note "1 · λ eq ⇒ λᴰ i ⇒ λ x ⇒ eq x i",
    note "    ⇐ (1·eq : (1·x : A) → p x ≡ q x) → p ≡ q",
    testTC "funext" $
      check_ (ctx [<]) sone
        (["eq"] :\\ ["i"] :\\% ["x"] :\\ E (BV 1 :@ BVT 0 :% BV 0))
        (Pi One "eq"
            (Pi One "x" (FT "A") $ TUsed $
              Eq0 (E $ F "P" :@ BVT 0)
                  (E $ F "p" :@ BVT 0) (E $ F "q" :@ BVT 0)) $ TUsed $
         Eq0 (Pi Any "x" (FT "A") $ TUsed $ E $ F "P" :@ BVT 0)
             (FT "p") (FT "q"))
  ]
]