quox/tests/Tests/Typechecker.idr

257 lines
9.6 KiB
Idris
Raw Normal View History

2023-02-11 12:15:50 -05:00
module Tests.Typechecker
import Quox.Syntax
import Quox.Syntax.Qty.Three
import Quox.Typechecker as Lib
import public TypingImpls
import TAP
2023-02-13 16:06:53 -05:00
data Error'
= TCError (Typing.Error Three)
| WrongInfer (Term Three d n) (Term Three d n)
| WrongQOut (QOutput Three n) (QOutput Three n)
export
ToInfo Error' where
toInfo (TCError e) = toInfo e
toInfo (WrongInfer good bad) =
[("type", "WrongInfer"),
("wanted", prettyStr True good),
("got", prettyStr True bad)]
toInfo (WrongQOut good bad) =
[("type", "WrongQOut"),
("wanted", prettyStr True good),
("wanted", prettyStr True bad)]
2023-02-11 12:15:50 -05:00
0 M : Type -> Type
2023-02-13 16:06:53 -05:00
M = ReaderT (Definitions Three) $ Either Error'
2023-02-11 12:15:50 -05:00
2023-02-13 16:06:53 -05:00
inj : (forall m. CanTC Three m => m a) -> M a
inj act = do
env <- ask
let res = runReaderT env act {m = Either (Typing.Error Three)}
either (throwError . TCError) pure res
2023-02-11 12:15:50 -05:00
reflTy : IsQty q => Term q d n
reflTy =
Pi zero "A" (TYPE 0) $ TUsed $
2023-02-12 15:30:08 -05:00
Pi one "x" (BVT 0) $ TUsed $
2023-02-11 12:15:50 -05:00
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
2023-02-13 16:06:53 -05:00
[("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"),
("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")),
("f2", mkAbstract Any $ Arr One (FT "A") $ Arr One (FT "A") (FT "A")),
("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),
2023-02-11 12:15:50 -05:00
("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
2023-02-14 15:14:47 -05:00
ctx : TContext Three 0 n -> TyContext Three 0 n
2023-02-14 15:29:04 -05:00
ctx = MkTyContext new
2023-02-11 12:15:50 -05:00
2023-02-13 16:06:53 -05:00
inferredTypeEq : TyContext Three d n -> (exp, got : Term Three d n) -> M ()
inferredTypeEq ctx exp got =
catchError
(inj $ equalType ctx exp got)
2023-02-13 16:06:53 -05:00
(\_ : Error' => throwError $ WrongInfer exp got)
qoutEq : (exp, got : QOutput Three n) -> M ()
qoutEq qout res = unless (qout == res) $ throwError $ WrongQOut qout res
2023-02-11 12:15:50 -05:00
inferAs : TyContext Three d n -> (sg : SQty Three) ->
Elim Three d n -> Term Three d n -> M ()
2023-02-19 11:51:44 -05:00
inferAs ctx@(MkTyContext {dctx, _}) sg e ty = do
case !(inj $ infer ctx sg e) of
Just res => inferredTypeEq ctx ty res.type
Nothing => pure ()
2023-02-13 16:06:53 -05:00
inferAsQ : TyContext Three d n -> (sg : SQty Three) ->
Elim Three d n -> Term Three d n -> QOutput Three n -> M ()
2023-02-19 11:51:44 -05:00
inferAsQ ctx@(MkTyContext {dctx, _}) sg e ty qout = do
case !(inj $ infer ctx sg e) of
Just res => do
inferredTypeEq ctx ty res.type
qoutEq qout res.qout
Nothing => pure ()
2023-02-11 12:15:50 -05:00
infer_ : TyContext Three d n -> (sg : SQty Three) -> Elim Three d n -> M ()
2023-02-13 16:06:53 -05:00
infer_ ctx sg e = ignore $ inj $ infer ctx sg e
checkQ : TyContext Three d n -> SQty Three ->
Term Three d n -> Term Three d n -> QOutput Three n -> M ()
2023-02-19 11:51:44 -05:00
checkQ ctx@(MkTyContext {dctx, _}) sg s ty qout = do
case !(inj $ check ctx sg s ty) of
Just res => qoutEq qout res
Nothing => pure ()
2023-02-11 12:15:50 -05:00
check_ : TyContext Three d n -> SQty Three ->
Term Three d n -> Term Three d n -> M ()
2023-02-13 16:06:53 -05:00
check_ ctx sg s ty = ignore $ inj $ check ctx sg s ty
2023-02-11 12:15:50 -05:00
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),
2023-02-19 11:51:44 -05:00
testTCFail "1 · ★₀ ⇍ ★₁" $ check_ (ctx [<]) sone (TYPE 0) (TYPE 1),
testTC "0=1 ⊢ 0 · ★₁ ⇐ ★₀" $
check_ (MkTyContext (ZeroIsOne {d = 0}) [<]) szero (TYPE 1) (TYPE 0)
2023-02-11 12:15:50 -05:00
],
"function types" :- [
2023-02-13 16:06:53 -05:00
note "A, B : ★₀; C, D : ★₁; P : A ⇾ ★₀",
2023-02-12 15:30:08 -05:00
testTC "0 · A ⊸ B ⇐ ★₀" $
2023-02-11 12:15:50 -05:00
check_ (ctx [<]) szero (Arr One (FT "A") (FT "B")) (TYPE 0),
2023-02-12 15:30:08 -05:00
note "subtyping",
testTC "0 · A ⊸ B ⇐ ★₁" $
2023-02-11 12:15:50 -05:00
check_ (ctx [<]) szero (Arr One (FT "A") (FT "B")) (TYPE 1),
2023-02-12 15:30:08 -05:00
testTC "0 · C ⊸ D ⇐ ★₁" $
2023-02-11 12:15:50 -05:00
check_ (ctx [<]) szero (Arr One (FT "C") (FT "D")) (TYPE 1),
2023-02-12 15:30:08 -05:00
testTCFail "0 · C ⊸ D ⇍ ★₀" $
2023-02-13 16:06:53 -05:00
check_ (ctx [<]) szero (Arr One (FT "C") (FT "D")) (TYPE 0),
testTC "0 · (1·x : A) → P x ⇐ ★₀" $
check_ (ctx [<]) szero
(Pi One "x" (FT "A") $ TUsed $ E $ F "P" :@ BVT 0)
(TYPE 0),
testTCFail "0 · A ⊸ P ⇍ ★₀" $
2023-02-19 11:51:44 -05:00
check_ (ctx [<]) szero (Arr One (FT "A") $ FT "P") (TYPE 0),
testTC "0=1 ⊢ 0 · A ⊸ P ⇐ ★₀" $
check_ (MkTyContext (ZeroIsOne {d = 0}) [<]) szero
(Arr One (FT "A") $ FT "P") (TYPE 0)
2023-02-13 16:06:53 -05:00
],
"pair types" :- [
note #""A × B" for "(_ : A) × B""#,
testTC "0 · A × A ⇐ ★₀" $
check_ (ctx [<]) szero (FT "A" `And` FT "A") (TYPE 0),
testTCFail "1 · A × A ⇍ ★₀" $
check_ (ctx [<]) sone (FT "A" `And` FT "A") (TYPE 0)
2023-02-11 12:15:50 -05:00
],
"free vars" :- [
2023-02-12 15:30:08 -05:00
note "A : ★₀",
2023-02-11 12:15:50 -05:00
testTC "0 · A ⇒ ★₀" $
inferAs (ctx [<]) szero (F "A") (TYPE 0),
2023-02-13 16:06:53 -05:00
testTC "0 · [A] ⇐ ★₀" $
2023-02-11 12:15:50 -05:00
check_ (ctx [<]) szero (FT "A") (TYPE 0),
2023-02-12 15:30:08 -05:00
note "subtyping",
2023-02-13 16:06:53 -05:00
testTC "0 · [A] ⇐ ★₁" $
2023-02-11 12:15:50 -05:00
check_ (ctx [<]) szero (FT "A") (TYPE 1),
2023-02-12 15:30:08 -05:00
note "(fail) runtime-relevant type",
testTCFail "1 · A ⇏ ★₀" $
2023-02-11 12:15:50 -05:00
infer_ (ctx [<]) sone (F "A"),
2023-02-12 15:30:08 -05:00
note "refl : (0·A : ★₀) → (1·x : A) → (x ≡ x : A) ≔ (λ A x ⇒ λᴰ _ ⇒ x)",
testTC "1 · refl ⇒ ⋯" $ inferAs (ctx [<]) sone (F "refl") reflTy,
2023-02-13 16:06:53 -05:00
testTC "1 · [refl] ⇐ ⋯" $ check_ (ctx [<]) sone (FT "refl") reflTy
],
"bound vars" :- [
2023-02-14 15:14:47 -05:00
testTC "x : A ⊢ 1 · x ⇒ A ⊳ 1·x" $
inferAsQ {n = 1} (ctx [< FT "A"]) sone
2023-02-13 16:06:53 -05:00
(BV 0) (FT "A") [< one],
2023-02-14 15:14:47 -05:00
testTC "x : A ⊢ 1 · [x] ⇐ A ⊳ 1·x" $
checkQ {n = 1} (ctx [< FT "A"]) sone (BVT 0) (FT "A") [< one],
2023-02-13 16:06:53 -05:00
note "f2 : A ⊸ A ⊸ A",
2023-02-14 15:14:47 -05:00
testTC "x : A ⊢ 1 · f2 [x] [x] ⇒ A ⊳ ω·x" $
inferAsQ {n = 1} (ctx [< FT "A"]) sone
(F "f2" :@@ [BVT 0, BVT 0]) (FT "A") [< Any]
2023-02-11 12:15:50 -05:00
],
"lambda" :- [
2023-02-12 15:30:08 -05:00
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)" $
2023-02-11 12:15:50 -05:00
check_ (ctx [<]) sone
(["A", "x"] :\\ E (F "refl" :@@ [BVT 1, BVT 0]))
2023-02-12 15:30:08 -05:00
reflTy,
testTC "1 · (λ A x ⇒ λᴰ i ⇒ x) ⇐ ⋯ # (def. and type of refl)" $
check_ (ctx [<]) sone reflDef reflTy
2023-02-11 12:15:50 -05:00
],
2023-02-13 16:06:53 -05:00
"equalities" :- [
testTC "1 · (λᴰ i ⇒ a) ⇐ a ≡ a" $
check_ (ctx [<]) sone (DLam "i" $ DUnused $ FT "a")
(Eq0 (FT "A") (FT "a") (FT "a")),
testTC "0 · (λ p q ⇒ λᴰ i ⇒ p) ⇐ (ω·p q : a ≡ a') → p ≡ q" $
check_ (ctx [<]) szero
(Lam "p" $ TUsed $ Lam "q" $ TUnused $
DLam "i" $ DUnused $ BVT 0)
(Pi Any "p" (Eq0 (FT "A") (FT "a") (FT "a")) $ TUsed $
Pi Any "q" (Eq0 (FT "A") (FT "a") (FT "a")) $ TUsed $
Eq0 (Eq0 (FT "A") (FT "a") (FT "a")) (BVT 1) (BVT 0)),
testTC "0 · (λ p q ⇒ λᴰ i ⇒ q) ⇐ (ω·p q : a ≡ a') → p ≡ q" $
check_ (ctx [<]) szero
(Lam "p" $ TUnused $ Lam "q" $ TUsed $
DLam "i" $ DUnused $ BVT 0)
(Pi Any "p" (Eq0 (FT "A") (FT "a") (FT "a")) $ TUsed $
Pi Any "q" (Eq0 (FT "A") (FT "a") (FT "a")) $ TUsed $
Eq0 (Eq0 (FT "A") (FT "a") (FT "a")) (BVT 1) (BVT 0))
],
2023-02-11 12:15:50 -05:00
"misc" :- [
2023-02-12 15:30:08 -05:00
note "0·A : Type, 0·P : A → Type, ω·p : (1·x : A) → P x",
note "",
note "1 · λ x y xy ⇒ λᴰ i ⇒ p (xy i)",
2023-02-13 16:06:53 -05:00
note " ⇐ (0·x y : A) → (1·xy : x ≡ y) → Eq [i ⇒ P (xy i)] (p x) (p y)",
2023-02-12 15:30:08 -05:00
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,",
2023-02-13 16:06:53 -05:00
note "ω·p q : (1·x : A) → P x",
2023-02-12 15:30:08 -05:00
note "",
note "1 · λ eq ⇒ λᴰ i ⇒ λ x ⇒ eq x i",
2023-02-13 16:06:53 -05:00
note " ⇐ (1·eq : (1·x : A) → p x ≡ q x) → p ≡ q",
2023-02-12 15:30:08 -05:00
testTC "funext" $
check_ (ctx [<]) sone
2023-02-11 12:15:50 -05:00
(["eq"] :\\ ["i"] :\\% ["x"] :\\ E (BV 1 :@ BVT 0 :% BV 0))
2023-02-12 15:30:08 -05:00
(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"))
2023-02-11 12:15:50 -05:00
]
]