quox/tests/Tests/Typechecker.idr

138 lines
4.8 KiB
Idris

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 zero "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),
("a", mkAbstract Any $ FT "A"),
("b", mkAbstract Any $ FT "B"),
("f", mkAbstract Any $ Arr One (FT "A") (FT "A")),
("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 · (1·A) → B ⇐ ★₀" $
check_ (ctx [<]) szero (Arr One (FT "A") (FT "B")) (TYPE 0),
testTC "0 · (1·A) → B ⇐ ★₁👈" $
check_ (ctx [<]) szero (Arr One (FT "A") (FT "B")) (TYPE 1),
testTC "0 · (1·C) → D ⇐ ★₁" $
check_ (ctx [<]) szero (Arr One (FT "C") (FT "D")) (TYPE 1),
testTCFail "0 · (1·C) → D ⇍ ★₀" $
check_ (ctx [<]) szero (Arr One (FT "C") (FT "D")) (TYPE 0)
],
"free vars" :- [
testTC "0 · A ⇒ ★₀" $
inferAs (ctx [<]) szero (F "A") (TYPE 0),
testTC "0 · A ⇐👈 ★₀" $
check_ (ctx [<]) szero (FT "A") (TYPE 0),
testTC "0 · A ⇐ ★₁👈" $
check_ (ctx [<]) szero (FT "A") (TYPE 1),
testTCFail "1👈 · A ⇏ ★₀" $
infer_ (ctx [<]) sone (F "A"),
note "refl : (0·A : ★₀) → (0·x : A) → (x ≡ x : A) ≔ (λ A x ⇒ λᴰ _ ⇒ x)",
testTC "1 · refl ⇒ {type of refl}" $
inferAs (ctx [<]) sone (F "refl") reflTy,
testTC "1 · refl ⇐ {type of refl}" $
check_ (ctx [<]) sone (FT "refl") reflTy
],
"lambda" :- [
testTC #"1 · (λ A x ⇒ refl A x) ⇐ {type of refl, see "free vars"}"# $
check_ (ctx [<]) sone
(["A", "x"] :\\ E (F "refl" :@@ [BVT 1, BVT 0]))
reflTy
],
"misc" :- [
testTC "funext"
{globals = fromList
[("A", mkAbstract Zero $ TYPE 0),
("B", mkAbstract Zero $ Arr Any (FT "A") (TYPE 0)),
("f", mkAbstract Any $
Pi Any "x" (FT "A") $ TUsed $ E $ F "B" :@ BVT 0),
("g", mkAbstract Any $
Pi Any "x" (FT "A") $ TUsed $ E $ F "B" :@ BVT 0)]} $
-- 0·A : Type, 0·B : ω·A → Type,
-- ω·f, g : (ω·x : A) → B x
-- ⊢
-- 0·funext : (ω·eq : (0·x : A) → f x ≡ g x) → f ≡ g
-- = λ eq ⇒ λᴰ i ⇒ λ x ⇒ eq x i
check_ (ctx [<]) szero
(["eq"] :\\ ["i"] :\\% ["x"] :\\ E (BV 1 :@ BVT 0 :% BV 0))
(Pi Any "eq"
(Pi Zero "x" (FT "A") $ TUsed $
Eq0 (E $ F "B" :@ BVT 0)
(E $ F "f" :@ BVT 0) (E $ F "g" :@ BVT 0)) $ TUsed $
Eq0 (Pi Any "x" (FT "A") $ TUsed $ E $ F "B" :@ BVT 0)
(FT "f") (FT "g"))
]
]