remove IsQty interface
This commit is contained in:
parent
5fdba77d04
commit
ba2818a865
24 changed files with 729 additions and 889 deletions
|
|
@ -20,7 +20,7 @@ eqSubstLen _ _ = Nothing
|
|||
|
||||
mutual
|
||||
export covering
|
||||
Eq q => Eq (Term q d n) where
|
||||
Eq (Term d n) where
|
||||
TYPE k == TYPE l = k == l
|
||||
TYPE _ == _ = False
|
||||
|
||||
|
|
@ -82,7 +82,7 @@ mutual
|
|||
DCloT {} == _ = False
|
||||
|
||||
export covering
|
||||
Eq q => Eq (Elim q d n) where
|
||||
Eq (Elim d n) where
|
||||
F x == F y = x == y
|
||||
F _ == _ = False
|
||||
|
||||
|
|
@ -128,9 +128,9 @@ mutual
|
|||
DCloE {} == _ = False
|
||||
|
||||
export covering
|
||||
IsQty q => PrettyHL q => Show (Term q d n) where
|
||||
Show (Term d n) where
|
||||
showPrec d t = showParens (d /= Open) $ prettyStr True t
|
||||
|
||||
export covering
|
||||
IsQty q => PrettyHL q => Show (Elim q d n) where
|
||||
Show (Elim d n) where
|
||||
showPrec d e = showParens (d /= Open) $ prettyStr True e
|
||||
|
|
|
|||
|
|
@ -2,28 +2,24 @@ module Tests.Equal
|
|||
|
||||
import Quox.Equal
|
||||
import Quox.Typechecker
|
||||
import Quox.Syntax.Qty.Three
|
||||
import public TypingImpls
|
||||
import TAP
|
||||
import Quox.EffExtra
|
||||
|
||||
0 M : Type -> Type
|
||||
M = TC Three
|
||||
|
||||
defGlobals : Definitions Three
|
||||
defGlobals : Definitions
|
||||
defGlobals = fromList
|
||||
[("A", mkPostulate Zero $ TYPE 0),
|
||||
("B", mkPostulate Zero $ TYPE 0),
|
||||
("a", mkPostulate Any $ FT "A"),
|
||||
("a'", mkPostulate Any $ FT "A"),
|
||||
("b", mkPostulate Any $ FT "B"),
|
||||
("f", mkPostulate Any $ Arr One (FT "A") (FT "A")),
|
||||
("id", mkDef Any (Arr One (FT "A") (FT "A")) ([< "x"] :\\ BVT 0)),
|
||||
("eq-AB", mkPostulate Zero $ Eq0 (TYPE 0) (FT "A") (FT "B")),
|
||||
("two", mkDef Any Nat (Succ (Succ Zero)))]
|
||||
[("A", mkPostulate gzero $ TYPE 0),
|
||||
("B", mkPostulate gzero $ TYPE 0),
|
||||
("a", mkPostulate gany $ FT "A"),
|
||||
("a'", mkPostulate gany $ FT "A"),
|
||||
("b", mkPostulate gany $ FT "B"),
|
||||
("f", mkPostulate gany $ Arr One (FT "A") (FT "A")),
|
||||
("id", mkDef gany (Arr One (FT "A") (FT "A")) ([< "x"] :\\ BVT 0)),
|
||||
("eq-AB", mkPostulate gzero $ Eq0 (TYPE 0) (FT "A") (FT "B")),
|
||||
("two", mkDef gany Nat (Succ (Succ Zero)))]
|
||||
|
||||
parameters (label : String) (act : Lazy (M ()))
|
||||
{default defGlobals globals : Definitions Three}
|
||||
parameters (label : String) (act : Lazy (TC ()))
|
||||
{default defGlobals globals : Definitions}
|
||||
testEq : Test
|
||||
testEq = test label $ runTC globals act
|
||||
|
||||
|
|
@ -31,29 +27,29 @@ parameters (label : String) (act : Lazy (M ()))
|
|||
testNeq = testThrows label (const True) $ runTC globals act $> "()"
|
||||
|
||||
|
||||
parameters (0 d : Nat) (ctx : TyContext Three d n)
|
||||
subTD, equalTD : Term Three d n -> Term Three d n -> Term Three d n -> M ()
|
||||
parameters (0 d : Nat) (ctx : TyContext d n)
|
||||
subTD, equalTD : Term d n -> Term d n -> Term d n -> TC ()
|
||||
subTD ty s t = Term.sub ctx ty s t
|
||||
equalTD ty s t = Term.equal ctx ty s t
|
||||
equalTyD : Term Three d n -> Term Three d n -> M ()
|
||||
equalTyD : Term d n -> Term d n -> TC ()
|
||||
equalTyD s t = Term.equalType ctx s t
|
||||
|
||||
subED, equalED : Elim Three d n -> Elim Three d n -> M ()
|
||||
subED, equalED : Elim d n -> Elim d n -> TC ()
|
||||
subED e f = Elim.sub ctx e f
|
||||
equalED e f = Elim.equal ctx e f
|
||||
|
||||
parameters (ctx : TyContext Three 0 n)
|
||||
subT, equalT : Term Three 0 n -> Term Three 0 n -> Term Three 0 n -> M ()
|
||||
parameters (ctx : TyContext 0 n)
|
||||
subT, equalT : Term 0 n -> Term 0 n -> Term 0 n -> TC ()
|
||||
subT = subTD 0 ctx
|
||||
equalT = equalTD 0 ctx
|
||||
equalTy : Term Three 0 n -> Term Three 0 n -> M ()
|
||||
equalTy : Term 0 n -> Term 0 n -> TC ()
|
||||
equalTy = equalTyD 0 ctx
|
||||
|
||||
subE, equalE : Elim Three 0 n -> Elim Three 0 n -> M ()
|
||||
subE, equalE : Elim 0 n -> Elim 0 n -> TC ()
|
||||
subE = subED 0 ctx
|
||||
equalE = equalED 0 ctx
|
||||
|
||||
empty01 : TyContext q 0 0
|
||||
empty01 : TyContext 0 0
|
||||
empty01 = eqDim (K Zero) (K One) empty
|
||||
|
||||
|
||||
|
|
@ -166,7 +162,7 @@ tests = "equality & subtyping" :- [
|
|||
let tm = Eq0 (TYPE 1) (TYPE 0) (TYPE 0) in
|
||||
equalT empty (TYPE 2) tm tm,
|
||||
testEq "A ≔ ★₁ ⊢ (★₀ ≡ ★₀ : ★₁) = (★₀ ≡ ★₀ : A)"
|
||||
{globals = fromList [("A", mkDef zero (TYPE 2) (TYPE 1))]} $
|
||||
{globals = fromList [("A", mkDef gzero (TYPE 2) (TYPE 1))]} $
|
||||
equalT empty (TYPE 2)
|
||||
(Eq0 (TYPE 1) (TYPE 0) (TYPE 0))
|
||||
(Eq0 (FT "A") (TYPE 0) (TYPE 0)),
|
||||
|
|
@ -174,7 +170,7 @@ tests = "equality & subtyping" :- [
|
|||
],
|
||||
|
||||
"equalities and uip" :-
|
||||
let refl : Term q d n -> Term q d n -> Elim q d n
|
||||
let refl : Term d n -> Term d n -> Elim d n
|
||||
refl a x = (DLam $ S [< "_"] $ N x) :# (Eq0 a x x)
|
||||
in
|
||||
[
|
||||
|
|
@ -185,53 +181,53 @@ tests = "equality & subtyping" :- [
|
|||
|
||||
testEq "p : (a ≡ a' : A), q : (a ≡ a' : A) ∥ ⊢ p = q (free)"
|
||||
{globals =
|
||||
let def = mkPostulate Zero $ Eq0 (FT "A") (FT "a") (FT "a'") in
|
||||
let def = mkPostulate gzero $ Eq0 (FT "A") (FT "a") (FT "a'") in
|
||||
defGlobals `mergeLeft` fromList [("p", def), ("q", def)]} $
|
||||
equalE empty (F "p") (F "q"),
|
||||
|
||||
testEq "∥ x : (a ≡ a' : A), y : (a ≡ a' : A) ⊢ x = y (bound)" $
|
||||
let ty : forall n. Term Three 0 n := Eq0 (FT "A") (FT "a") (FT "a'") in
|
||||
let ty : forall n. Term 0 n := Eq0 (FT "A") (FT "a") (FT "a'") in
|
||||
equalE (extendTyN [< (Any, "x", ty), (Any, "y", ty)] empty)
|
||||
(BV 0) (BV 1),
|
||||
|
||||
testEq "∥ x : [(a ≡ a' : A) ∷ Type 0], y : [ditto] ⊢ x = y" $
|
||||
let ty : forall n. Term Three 0 n :=
|
||||
let ty : forall n. Term 0 n :=
|
||||
E (Eq0 (FT "A") (FT "a") (FT "a'") :# TYPE 0) in
|
||||
equalE (extendTyN [< (Any, "x", ty), (Any, "y", ty)] empty)
|
||||
(BV 0) (BV 1),
|
||||
|
||||
testEq "E ≔ a ≡ a' : A, EE ≔ E ∥ x : EE, y : EE ⊢ x = y"
|
||||
{globals = defGlobals `mergeLeft` fromList
|
||||
[("E", mkDef zero (TYPE 0) (Eq0 (FT "A") (FT "a") (FT "a'"))),
|
||||
("EE", mkDef zero (TYPE 0) (FT "E"))]} $
|
||||
[("E", mkDef gzero (TYPE 0) (Eq0 (FT "A") (FT "a") (FT "a'"))),
|
||||
("EE", mkDef gzero (TYPE 0) (FT "E"))]} $
|
||||
equalE (extendTyN [< (Any, "x", FT "EE"), (Any, "y", FT "EE")] empty)
|
||||
(BV 0) (BV 1),
|
||||
|
||||
testEq "E ≔ a ≡ a' : A, EE ≔ E ∥ x : EE, y : E ⊢ x = y"
|
||||
{globals = defGlobals `mergeLeft` fromList
|
||||
[("E", mkDef zero (TYPE 0) (Eq0 (FT "A") (FT "a") (FT "a'"))),
|
||||
("EE", mkDef zero (TYPE 0) (FT "E"))]} $
|
||||
[("E", mkDef gzero (TYPE 0) (Eq0 (FT "A") (FT "a") (FT "a'"))),
|
||||
("EE", mkDef gzero (TYPE 0) (FT "E"))]} $
|
||||
equalE (extendTyN [< (Any, "x", FT "EE"), (Any, "y", FT "E")] empty)
|
||||
(BV 0) (BV 1),
|
||||
|
||||
testEq "E ≔ a ≡ a' : A ∥ x : E, y : E ⊢ x = y"
|
||||
{globals = defGlobals `mergeLeft` fromList
|
||||
[("E", mkDef zero (TYPE 0) (Eq0 (FT "A") (FT "a") (FT "a'")))]} $
|
||||
[("E", mkDef gzero (TYPE 0) (Eq0 (FT "A") (FT "a") (FT "a'")))]} $
|
||||
equalE (extendTyN [< (Any, "x", FT "E"), (Any, "y", FT "E")] empty)
|
||||
(BV 0) (BV 1),
|
||||
|
||||
testEq "E ≔ a ≡ a' : A ∥ x : (E×E), y : (E×E) ⊢ x = y"
|
||||
{globals = defGlobals `mergeLeft` fromList
|
||||
[("E", mkDef zero (TYPE 0) (Eq0 (FT "A") (FT "a") (FT "a'")))]} $
|
||||
let ty : forall n. Term Three 0 n :=
|
||||
[("E", mkDef gzero (TYPE 0) (Eq0 (FT "A") (FT "a") (FT "a'")))]} $
|
||||
let ty : forall n. Term 0 n :=
|
||||
Sig (FT "E") $ S [< "_"] $ N $ FT "E" in
|
||||
equalE (extendTyN [< (Any, "x", ty), (Any, "y", ty)] empty)
|
||||
(BV 0) (BV 1),
|
||||
|
||||
testEq "E ≔ a ≡ a' : A, W ≔ E × E ∥ x : W, y : W ⊢ x = y"
|
||||
{globals = defGlobals `mergeLeft` fromList
|
||||
[("E", mkDef zero (TYPE 0) (Eq0 (FT "A") (FT "a") (FT "a'"))),
|
||||
("W", mkDef zero (TYPE 0) (FT "E" `And` FT "E"))]} $
|
||||
[("E", mkDef gzero (TYPE 0) (Eq0 (FT "A") (FT "a") (FT "a'"))),
|
||||
("W", mkDef gzero (TYPE 0) (FT "E" `And` FT "E"))]} $
|
||||
equalE
|
||||
(extendTyN [< (Any, "x", FT "W"), (Any, "y", FT "W")] empty)
|
||||
(BV 0) (BV 1)
|
||||
|
|
@ -281,11 +277,11 @@ tests = "equality & subtyping" :- [
|
|||
|
||||
"free var" :-
|
||||
let au_bu = fromList
|
||||
[("A", mkDef Any (TYPE 1) (TYPE 0)),
|
||||
("B", mkDef Any (TYPE 1) (TYPE 0))]
|
||||
[("A", mkDef gany (TYPE 1) (TYPE 0)),
|
||||
("B", mkDef gany (TYPE 1) (TYPE 0))]
|
||||
au_ba = fromList
|
||||
[("A", mkDef Any (TYPE 1) (TYPE 0)),
|
||||
("B", mkDef Any (TYPE 1) (FT "A"))]
|
||||
[("A", mkDef gany (TYPE 1) (TYPE 0)),
|
||||
("B", mkDef gany (TYPE 1) (FT "A"))]
|
||||
in [
|
||||
testEq "A = A" $
|
||||
equalE empty (F "A") (F "A"),
|
||||
|
|
@ -306,13 +302,13 @@ tests = "equality & subtyping" :- [
|
|||
testNeq "A ≮: B" $
|
||||
subE empty (F "A") (F "B"),
|
||||
testEq "A : ★₃ ≔ ★₀, B : ★₃ ≔ ★₂ ⊢ A <: B"
|
||||
{globals = fromList [("A", mkDef Any (TYPE 3) (TYPE 0)),
|
||||
("B", mkDef Any (TYPE 3) (TYPE 2))]} $
|
||||
{globals = fromList [("A", mkDef gany (TYPE 3) (TYPE 0)),
|
||||
("B", mkDef gany (TYPE 3) (TYPE 2))]} $
|
||||
subE empty (F "A") (F "B"),
|
||||
note "(A and B in different universes)",
|
||||
testEq "A : ★₁ ≔ ★₀, B : ★₃ ≔ ★₂ ⊢ A <: B"
|
||||
{globals = fromList [("A", mkDef Any (TYPE 1) (TYPE 0)),
|
||||
("B", mkDef Any (TYPE 3) (TYPE 2))]} $
|
||||
{globals = fromList [("A", mkDef gany (TYPE 1) (TYPE 0)),
|
||||
("B", mkDef gany (TYPE 3) (TYPE 2))]} $
|
||||
subE empty (F "A") (F "B"),
|
||||
testEq "0=1 ⊢ A <: B" $
|
||||
subE empty01 (F "A") (F "B")
|
||||
|
|
|
|||
|
|
@ -2,25 +2,24 @@ module Tests.PrettyTerm
|
|||
|
||||
import TAP
|
||||
import Quox.Syntax
|
||||
import Quox.Syntax.Qty.Three
|
||||
import PrettyExtra
|
||||
|
||||
|
||||
parameters (ds : NContext d) (ns : NContext n)
|
||||
testPrettyT : Term Three d n -> (uni, asc : String) ->
|
||||
testPrettyT : Term d n -> (uni, asc : String) ->
|
||||
{default uni label : String} -> Test
|
||||
testPrettyT t uni asc {label} =
|
||||
testPretty (toSnocList' ds) (toSnocList' ns) t uni asc {label}
|
||||
|
||||
testPrettyT1 : Term Three d n -> (str : String) ->
|
||||
testPrettyT1 : Term d n -> (str : String) ->
|
||||
{default str label : String} -> Test
|
||||
testPrettyT1 t str {label} = testPrettyT t str str {label}
|
||||
|
||||
testPrettyE : Elim Three d n -> (uni, asc : String) ->
|
||||
testPrettyE : Elim d n -> (uni, asc : String) ->
|
||||
{default uni label : String} -> Test
|
||||
testPrettyE e uni asc {label} = testPrettyT (E e) uni asc {label}
|
||||
|
||||
testPrettyE1 : Elim Three d n -> (str : String) ->
|
||||
testPrettyE1 : Elim d n -> (str : String) ->
|
||||
{default str label : String} -> Test
|
||||
testPrettyE1 e str {label} = testPrettyT1 (E e) str {label}
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
module Tests.Reduce
|
||||
|
||||
import Quox.Syntax as Lib
|
||||
import Quox.Syntax.Qty.Three
|
||||
import Quox.Equal
|
||||
import TermImpls
|
||||
import TypingImpls
|
||||
|
|
@ -10,16 +9,16 @@ import TAP
|
|||
|
||||
parameters {0 isRedex : RedexTest tm} {auto _ : Whnf tm isRedex err}
|
||||
{auto _ : ToInfo err}
|
||||
{auto _ : forall d, n. Eq (tm Three d n)}
|
||||
{auto _ : forall d, n. Show (tm Three d n)}
|
||||
{default empty defs : Definitions Three}
|
||||
{auto _ : forall d, n. Eq (tm d n)}
|
||||
{auto _ : forall d, n. Show (tm d n)}
|
||||
{default empty defs : Definitions}
|
||||
{default 0 d, n : Nat}
|
||||
testWhnf : String -> tm Three d n -> tm Three d n -> Test
|
||||
testWhnf : String -> tm d n -> tm d n -> Test
|
||||
testWhnf label from to = test "\{label} (whnf)" $ do
|
||||
result <- bimap toInfo fst $ whnf defs from
|
||||
unless (result == to) $ Left [("exp", show to), ("got", show result)]
|
||||
|
||||
testNoStep : String -> tm Three d n -> Test
|
||||
testNoStep : String -> tm d n -> Test
|
||||
testNoStep label e = testWhnf label e e
|
||||
|
||||
|
||||
|
|
@ -57,7 +56,7 @@ tests = "whnf" :- [
|
|||
|
||||
"definitions" :- [
|
||||
testWhnf "a (transparent)"
|
||||
{defs = fromList [("a", mkDef Zero (TYPE 1) (TYPE 0))]}
|
||||
{defs = fromList [("a", mkDef gzero (TYPE 1) (TYPE 0))]}
|
||||
(F "a") (TYPE 0 :# TYPE 1)
|
||||
],
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
module Tests.Typechecker
|
||||
|
||||
import Quox.Syntax
|
||||
import Quox.Syntax.Qty.Three
|
||||
import Quox.Typechecker as Lib
|
||||
import public TypingImpls
|
||||
import TAP
|
||||
|
|
@ -9,9 +8,9 @@ import Quox.EffExtra
|
|||
|
||||
|
||||
data Error'
|
||||
= TCError (Typing.Error Three)
|
||||
| WrongInfer (Term Three d n) (Term Three d n)
|
||||
| WrongQOut (QOutput Three n) (QOutput Three n)
|
||||
= TCError Typing.Error
|
||||
| WrongInfer (Term d n) (Term d n)
|
||||
| WrongQOut (QOutput n) (QOutput n)
|
||||
|
||||
export
|
||||
ToInfo Error' where
|
||||
|
|
@ -26,41 +25,41 @@ ToInfo Error' where
|
|||
("wanted", prettyStr True bad)]
|
||||
|
||||
0 M : Type -> Type
|
||||
M = Eff [Except Error', DefsReader Three]
|
||||
M = Eff [Except Error', DefsReader]
|
||||
|
||||
inj : TC Three a -> M a
|
||||
inj : TC a -> M a
|
||||
inj = rethrow . mapFst TCError <=< lift . runExcept
|
||||
|
||||
|
||||
reflTy : IsQty q => Term q d n
|
||||
reflTy : Term d n
|
||||
reflTy =
|
||||
Pi_ zero "A" (TYPE 0) $
|
||||
Pi_ one "x" (BVT 0) $
|
||||
Pi_ Zero "A" (TYPE 0) $
|
||||
Pi_ One "x" (BVT 0) $
|
||||
Eq0 (BVT 1) (BVT 0) (BVT 0)
|
||||
|
||||
reflDef : IsQty q => Term q d n
|
||||
reflDef : Term d n
|
||||
reflDef = [< "A","x"] :\\ [< "i"] :\\% BVT 0
|
||||
|
||||
|
||||
fstTy : Term Three d n
|
||||
fstTy : Term d n
|
||||
fstTy =
|
||||
(Pi_ Zero "A" (TYPE 1) $
|
||||
Pi_ Zero "B" (Arr Any (BVT 0) (TYPE 1)) $
|
||||
Arr Any (Sig_ "x" (BVT 1) $ E $ BV 1 :@ BVT 0) (BVT 1))
|
||||
|
||||
fstDef : Term Three d n
|
||||
fstDef : Term d n
|
||||
fstDef =
|
||||
([< "A","B","p"] :\\
|
||||
E (CasePair Any (BV 0) (SN $ BVT 2) (SY [< "x","y"] $ BVT 1)))
|
||||
|
||||
sndTy : Term Three d n
|
||||
sndTy : Term d n
|
||||
sndTy =
|
||||
(Pi_ Zero "A" (TYPE 1) $
|
||||
Pi_ Zero "B" (Arr Any (BVT 0) (TYPE 1)) $
|
||||
Pi_ Any "p" (Sig_ "x" (BVT 1) $ E $ BV 1 :@ BVT 0) $
|
||||
E (BV 1 :@ E (F "fst" :@@ [BVT 2, BVT 1, BVT 0])))
|
||||
|
||||
sndDef : Term Three d n
|
||||
sndDef : Term d n
|
||||
sndDef =
|
||||
([< "A","B","p"] :\\
|
||||
E (CasePair Any (BV 0)
|
||||
|
|
@ -68,27 +67,27 @@ sndDef =
|
|||
(SY [< "x","y"] $ BVT 0)))
|
||||
|
||||
|
||||
defGlobals : Definitions Three
|
||||
defGlobals : Definitions
|
||||
defGlobals = fromList
|
||||
[("A", mkPostulate Zero $ TYPE 0),
|
||||
("B", mkPostulate Zero $ TYPE 0),
|
||||
("C", mkPostulate Zero $ TYPE 1),
|
||||
("D", mkPostulate Zero $ TYPE 1),
|
||||
("P", mkPostulate Zero $ Arr Any (FT "A") (TYPE 0)),
|
||||
("a", mkPostulate Any $ FT "A"),
|
||||
("a'", mkPostulate Any $ FT "A"),
|
||||
("b", mkPostulate Any $ FT "B"),
|
||||
("f", mkPostulate Any $ Arr One (FT "A") (FT "A")),
|
||||
("g", mkPostulate Any $ Arr One (FT "A") (FT "B")),
|
||||
("f2", mkPostulate Any $ Arr One (FT "A") $ Arr One (FT "A") (FT "B")),
|
||||
("p", mkPostulate Any $ Pi_ One "x" (FT "A") $ E $ F "P" :@ BVT 0),
|
||||
("q", mkPostulate Any $ Pi_ One "x" (FT "A") $ E $ F "P" :@ BVT 0),
|
||||
("refl", mkDef Any reflTy reflDef),
|
||||
("fst", mkDef Any fstTy fstDef),
|
||||
("snd", mkDef Any sndTy sndDef)]
|
||||
[("A", mkPostulate gzero $ TYPE 0),
|
||||
("B", mkPostulate gzero $ TYPE 0),
|
||||
("C", mkPostulate gzero $ TYPE 1),
|
||||
("D", mkPostulate gzero $ TYPE 1),
|
||||
("P", mkPostulate gzero $ Arr Any (FT "A") (TYPE 0)),
|
||||
("a", mkPostulate gany $ FT "A"),
|
||||
("a'", mkPostulate gany $ FT "A"),
|
||||
("b", mkPostulate gany $ FT "B"),
|
||||
("f", mkPostulate gany $ Arr One (FT "A") (FT "A")),
|
||||
("g", mkPostulate gany $ Arr One (FT "A") (FT "B")),
|
||||
("f2", mkPostulate gany $ Arr One (FT "A") $ Arr One (FT "A") (FT "B")),
|
||||
("p", mkPostulate gany $ Pi_ One "x" (FT "A") $ E $ F "P" :@ BVT 0),
|
||||
("q", mkPostulate gany $ Pi_ One "x" (FT "A") $ E $ F "P" :@ BVT 0),
|
||||
("refl", mkDef gany reflTy reflDef),
|
||||
("fst", mkDef gany fstTy fstDef),
|
||||
("snd", mkDef gany sndTy sndDef)]
|
||||
|
||||
parameters (label : String) (act : Lazy (M ()))
|
||||
{default defGlobals globals : Definitions Three}
|
||||
{default defGlobals globals : Definitions}
|
||||
testTC : Test
|
||||
testTC = test label {e = Error', a = ()} $
|
||||
extract $ runExcept $ runReader globals act
|
||||
|
|
@ -98,36 +97,35 @@ parameters (label : String) (act : Lazy (M ()))
|
|||
(extract $ runExcept $ runReader globals act) $> "()"
|
||||
|
||||
|
||||
anys : {n : Nat} -> QContext Three n
|
||||
anys : {n : Nat} -> QContext n
|
||||
anys {n = 0} = [<]
|
||||
anys {n = S n} = anys :< Any
|
||||
|
||||
ctx, ctx01 : {n : Nat} -> Context (\n => (BaseName, Term Three 0 n)) n ->
|
||||
TyContext Three 0 n
|
||||
ctx, ctx01 : {n : Nat} -> Context (\n => (BaseName, Term 0 n)) n ->
|
||||
TyContext 0 n
|
||||
ctx tel = let (ns, ts) = unzip tel in
|
||||
MkTyContext new [<] ts ns anys
|
||||
ctx01 tel = let (ns, ts) = unzip tel in
|
||||
MkTyContext ZeroIsOne [<] ts ns anys
|
||||
|
||||
empty01 : TyContext Three 0 0
|
||||
empty01 : TyContext 0 0
|
||||
empty01 = eqDim (K Zero) (K One) empty
|
||||
|
||||
inferredTypeEq : TyContext Three d n -> (exp, got : Term Three d n) -> M ()
|
||||
inferredTypeEq : TyContext d n -> (exp, got : Term d n) -> M ()
|
||||
inferredTypeEq ctx exp got =
|
||||
wrapErr (const $ WrongInfer exp got) $ inj $ equalType ctx exp got
|
||||
|
||||
qoutEq : (exp, got : QOutput Three n) -> M ()
|
||||
qoutEq : (exp, got : QOutput n) -> M ()
|
||||
qoutEq qout res = unless (qout == res) $ throw $ WrongQOut qout res
|
||||
|
||||
inferAs : TyContext Three d n -> (sg : SQty Three) ->
|
||||
Elim Three d n -> Term Three d n -> M ()
|
||||
inferAs : TyContext d n -> (sg : SQty) -> Elim d n -> Term d n -> M ()
|
||||
inferAs ctx@(MkTyContext {dctx, _}) sg e ty = do
|
||||
case !(inj $ infer ctx sg e) of
|
||||
Just res => inferredTypeEq ctx ty res.type
|
||||
Nothing => pure ()
|
||||
|
||||
inferAsQ : TyContext Three d n -> (sg : SQty Three) ->
|
||||
Elim Three d n -> Term Three d n -> QOutput Three n -> M ()
|
||||
inferAsQ : TyContext d n -> (sg : SQty) ->
|
||||
Elim d n -> Term d n -> QOutput n -> M ()
|
||||
inferAsQ ctx@(MkTyContext {dctx, _}) sg e ty qout = do
|
||||
case !(inj $ infer ctx sg e) of
|
||||
Just res => do
|
||||
|
|
@ -135,30 +133,23 @@ inferAsQ ctx@(MkTyContext {dctx, _}) sg e ty qout = do
|
|||
qoutEq qout res.qout
|
||||
Nothing => pure ()
|
||||
|
||||
infer_ : TyContext Three d n -> (sg : SQty Three) -> Elim Three d n -> M ()
|
||||
infer_ : TyContext d n -> (sg : SQty) -> Elim d n -> M ()
|
||||
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 ()
|
||||
checkQ : TyContext d n -> SQty ->
|
||||
Term d n -> Term d n -> QOutput n -> M ()
|
||||
checkQ ctx@(MkTyContext {dctx, _}) sg s ty qout = do
|
||||
case !(inj $ check ctx sg s ty) of
|
||||
Just res => qoutEq qout res
|
||||
Nothing => pure ()
|
||||
|
||||
check_ : TyContext Three d n -> SQty Three ->
|
||||
Term Three d n -> Term Three d n -> M ()
|
||||
check_ : TyContext d n -> SQty -> Term d n -> Term d n -> M ()
|
||||
check_ ctx sg s ty = ignore $ inj $ check ctx sg s ty
|
||||
|
||||
checkType_ : TyContext Three d n -> Term Three d n -> Maybe Universe -> M ()
|
||||
checkType_ : TyContext d n -> Term d n -> Maybe Universe -> M ()
|
||||
checkType_ ctx s u = inj $ checkType ctx s u
|
||||
|
||||
|
||||
-- ω is not a subject qty
|
||||
failing "Can't find an implementation"
|
||||
sany : SQty Three
|
||||
sany = Element Any %search
|
||||
|
||||
|
||||
export
|
||||
tests : Test
|
||||
tests = "typechecker" :- [
|
||||
|
|
@ -253,9 +244,9 @@ tests = "typechecker" :- [
|
|||
"bound vars" :- [
|
||||
testTC "x : A ⊢ 1 · x ⇒ A ⊳ 1·x" $
|
||||
inferAsQ {n = 1} (ctx [< ("x", FT "A")]) sone
|
||||
(BV 0) (FT "A") [< one],
|
||||
(BV 0) (FT "A") [< One],
|
||||
testTC "x : A ⊢ 1 · [x] ⇐ A ⊳ 1·x" $
|
||||
checkQ {n = 1} (ctx [< ("x", FT "A")]) sone (BVT 0) (FT "A") [< one],
|
||||
checkQ {n = 1} (ctx [< ("x", FT "A")]) sone (BVT 0) (FT "A") [< One],
|
||||
note "f2 : A ⊸ A ⊸ B",
|
||||
testTC "x : A ⊢ 1 · f2 [x] [x] ⇒ B ⊳ ω·x" $
|
||||
inferAsQ {n = 1} (ctx [< ("x", FT "A")]) sone
|
||||
|
|
@ -371,24 +362,30 @@ tests = "typechecker" :- [
|
|||
],
|
||||
|
||||
"equality types" :- [
|
||||
testTC "0 · ℕ = ℕ : ★₀ ⇐ ★₁" $
|
||||
testTC "0 · ℕ ≡ ℕ : ★₀ ⇐ Type" $
|
||||
checkType_ empty (Eq0 (TYPE 0) Nat Nat) Nothing,
|
||||
testTC "0 · ℕ ≡ ℕ : ★₀ ⇐ ★₁" $
|
||||
check_ empty szero (Eq0 (TYPE 0) Nat Nat) (TYPE 1),
|
||||
testTC "0 · ℕ = ℕ : ★₀ ⇐ ★₂" $
|
||||
testTCFail "1 · ℕ ≡ ℕ : ★₀ ⇍ ★₁" $
|
||||
check_ empty sone (Eq0 (TYPE 0) Nat Nat) (TYPE 1),
|
||||
testTC "0 · ℕ ≡ ℕ : ★₀ ⇐ ★₂" $
|
||||
check_ empty szero (Eq0 (TYPE 0) Nat Nat) (TYPE 2),
|
||||
testTC "0 · ℕ = ℕ : ★₁ ⇐ ★₂" $
|
||||
testTC "0 · ℕ ≡ ℕ : ★₁ ⇐ ★₂" $
|
||||
check_ empty szero (Eq0 (TYPE 1) Nat Nat) (TYPE 2),
|
||||
testTCFail "0 · ℕ = ℕ : ★₁ ⇍ ★₁" $
|
||||
testTCFail "0 · ℕ ≡ ℕ : ★₁ ⇍ ★₁" $
|
||||
check_ empty szero (Eq0 (TYPE 1) Nat Nat) (TYPE 1),
|
||||
testTC "ab : A ≡ B : ★₀, x : A, y : B ⊢ Eq [i ⇒ ab i] x y ⇐ ★₀" $
|
||||
testTCFail "0 ≡ 'beep : {beep} ⇍ Type" $
|
||||
checkType_ empty (Eq0 (enum ["beep"]) Zero (Tag "beep")) Nothing,
|
||||
testTC "ab : A ≡ B : ★₀, x : A, y : B ⊢ 0 · Eq [i ⇒ ab i] x y ⇐ ★₀" $
|
||||
check_ (ctx [< ("ab", Eq0 (TYPE 0) (FT "A") (FT "B")),
|
||||
("x", FT "A"), ("y", FT "B")]) szero
|
||||
(Eq (SY [< "i"] $ E $ BV 2 :% BV 0) (BVT 1) (BVT 0))
|
||||
(TYPE 0),
|
||||
testTCFail "ab : A ≡ B : ★₀, x : A, y : B ⊢ Eq [i ⇒ ab i] y x ⇍ ★₀" $
|
||||
check_ (ctx [< ("ab", Eq0 (TYPE 0) (FT "A") (FT "B")),
|
||||
("x", FT "A"), ("y", FT "B")]) szero
|
||||
testTCFail "ab : A ≡ B : ★₀, x : A, y : B ⊢ Eq [i ⇒ ab i] y x ⇍ Type" $
|
||||
checkType_ (ctx [< ("ab", Eq0 (TYPE 0) (FT "A") (FT "B")),
|
||||
("x", FT "A"), ("y", FT "B")])
|
||||
(Eq (SY [< "i"] $ E $ BV 2 :% BV 0) (BVT 0) (BVT 1))
|
||||
(TYPE 0)
|
||||
Nothing
|
||||
],
|
||||
|
||||
"equalities" :- [
|
||||
|
|
|
|||
|
|
@ -10,18 +10,9 @@ import Derive.Prelude
|
|||
|
||||
|
||||
%runElab derive "Reduce.WhnfError" [Show]
|
||||
|
||||
export %hint
|
||||
showTyContext : (IsQty q, PrettyHL q, Show q) => Show (TyContext q d n)
|
||||
showTyContext = deriveShow
|
||||
|
||||
export %hint
|
||||
showEqContext : (IsQty q, PrettyHL q, Show q) => Show (EqContext q n)
|
||||
showEqContext = deriveShow
|
||||
|
||||
export %hint
|
||||
showTypingError : (IsQty q, PrettyHL q, Show q) => Show (Error q)
|
||||
showTypingError = deriveShow
|
||||
%runElab deriveIndexed "TyContext" [Show]
|
||||
%runElab deriveIndexed "EqContext" [Show]
|
||||
%runElab derive "Error" [Show]
|
||||
|
||||
export
|
||||
ToInfo WhnfError where
|
||||
|
|
@ -31,5 +22,4 @@ ToInfo WhnfError where
|
|||
("list", show ts)]
|
||||
|
||||
export
|
||||
(IsQty q, PrettyHL q) => ToInfo (Error q) where
|
||||
toInfo err = [("err", show $ prettyError True True err)]
|
||||
ToInfo Error where toInfo err = [("err", show $ prettyError True True err)]
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue