typed equality

This commit is contained in:
rhiannon morris 2023-02-10 21:40:44 +01:00
parent 3b13f0a82c
commit 42798f243f
8 changed files with 410 additions and 250 deletions

View file

@ -26,11 +26,17 @@ ToInfo (Error Three) where
[("type", "BadUniverse"),
("low", show k),
("high", show l)]
toInfo (ClashT mode s t) =
toInfo (ClashT mode ty s t) =
[("type", "ClashT"),
("mode", show mode),
("ty", prettyStr True ty),
("left", prettyStr True s),
("right", prettyStr True t)]
toInfo (ClashE mode e f) =
[("type", "ClashE"),
("mode", show mode),
("left", prettyStr True e),
("right", prettyStr True f)]
toInfo (ClashU mode k l) =
[("type", "ClashU"),
("mode", show mode),
@ -44,13 +50,29 @@ ToInfo (Error Three) where
[("type", "ClashD"),
("left", prettyStr True p),
("right", prettyStr True q)]
toInfo (NotType ty) =
[("type", "NotType"),
("actual", prettyStr True ty)]
toInfo (WrongType ty s t) =
[("type", "WrongType"),
("ty", prettyStr True ty),
("left", prettyStr True s),
("right", prettyStr True t)]
0 M : Type -> Type
M = ReaderT (Definitions Three) (Either (Error Three))
defGlobals : Definitions Three
defGlobals = fromList
[("A", mkAbstract Zero $ TYPE 0),
("B", mkAbstract Zero $ TYPE 0),
("a", mkAbstract Any $ FT "A"),
("b", mkAbstract Any $ FT "B"),
("f", mkAbstract Any $ Arr One (FT "A") (FT "A"))]
parameters (label : String) (act : Lazy (M ()))
{default empty globals : Definitions Three}
{default defGlobals globals : Definitions Three}
testEq : Test
testEq = test label $ runReaderT globals act
@ -60,17 +82,18 @@ parameters (label : String) (act : Lazy (M ()))
parameters {default 0 d, n : Nat}
{default new eqs : DimEq d}
subT : Term Three d n -> Term Three d n -> M ()
subT s t = Term.sub !ask eqs s t
(ctx : TContext Three d n)
subT : Term Three d n -> Term Three d n -> Term Three d n -> M ()
subT ty s t = Term.sub eqs ctx ty s t
equalT : Term Three d n -> Term Three d n -> M ()
equalT s t = Term.equal !ask eqs s t
equalT : Term Three d n -> Term Three d n -> Term Three d n -> M ()
equalT ty s t = Term.equal eqs ctx ty s t
subE : Elim Three d n -> Elim Three d n -> M ()
subE e f = Elim.sub !ask eqs e f
subE e f = Elim.sub eqs ctx e f
equalE : Elim Three d n -> Elim Three d n -> M ()
equalE e f = Elim.equal !ask eqs e f
equalE e f = Elim.equal eqs ctx e f
export
@ -80,17 +103,17 @@ tests = "equality & subtyping" :- [
"universes" :- [
testEq "★₀ ≡ ★₀" $
equalT (TYPE 0) (TYPE 0),
equalT [<] (TYPE 1) (TYPE 0) (TYPE 0),
testNeq "★₀ ≢ ★₁" $
equalT (TYPE 0) (TYPE 1),
equalT [<] (TYPE 2) (TYPE 0) (TYPE 1),
testNeq "★₁ ≢ ★₀" $
equalT (TYPE 1) (TYPE 0),
equalT [<] (TYPE 2) (TYPE 1) (TYPE 0),
testEq "★₀ <: ★₀" $
subT (TYPE 0) (TYPE 0),
subT [<] (TYPE 1) (TYPE 0) (TYPE 0),
testEq "★₀ <: ★₁" $
subT (TYPE 0) (TYPE 1),
subT [<] (TYPE 2) (TYPE 0) (TYPE 1),
testNeq "★₁ ≮: ★₀" $
subT (TYPE 1) (TYPE 0)
subT [<] (TYPE 2) (TYPE 1) (TYPE 0)
],
"pi" :- [
@ -98,79 +121,91 @@ tests = "equality & subtyping" :- [
note #""AB" for (0 _ : A) → B"#,
testEq "A ⊸ B ≡ A ⊸ B" $
let tm = Arr One (FT "A") (FT "B") in
equalT tm tm,
equalT [<] (TYPE 0) tm tm,
testNeq "A ⇾ B ≢ A ⊸ B" $
let tm1 = Arr Zero (FT "A") (FT "B")
tm2 = Arr One (FT "A") (FT "B") in
equalT tm1 tm2,
equalT [<] (TYPE 0) tm1 tm2,
testEq "0=1 ⊢ A ⇾ B ≢ A ⊸ B" $
let tm1 = Arr Zero (FT "A") (FT "B")
tm2 = Arr One (FT "A") (FT "B") in
equalT tm1 tm2 {eqs = ZeroIsOne},
equalT [<] (TYPE 0) tm1 tm2 {eqs = ZeroIsOne},
testEq "A ⊸ B <: A ⊸ B" $
let tm = Arr One (FT "A") (FT "B") in
subT tm tm,
subT [<] (TYPE 0) tm tm,
testNeq "A ⇾ B ≮: A ⊸ B" $
let tm1 = Arr Zero (FT "A") (FT "B")
tm2 = Arr One (FT "A") (FT "B") in
subT tm1 tm2,
subT [<] (TYPE 0) tm1 tm2,
testEq "★₀ ⇾ ★₀ ≡ ★₀ ⇾ ★₀" $
let tm = Arr Zero (TYPE 0) (TYPE 0) in
equalT tm tm,
equalT [<] (TYPE 1) tm tm,
testEq "★₀ ⇾ ★₀ <: ★₀ ⇾ ★₀" $
let tm = Arr Zero (TYPE 0) (TYPE 0) in
subT tm tm,
subT [<] (TYPE 1) tm tm,
testNeq "★₁ ⊸ ★₀ ≢ ★₀ ⇾ ★₀" $
let tm1 = Arr Zero (TYPE 1) (TYPE 0)
tm2 = Arr Zero (TYPE 0) (TYPE 0) in
equalT tm1 tm2,
equalT [<] (TYPE 2) tm1 tm2,
testEq "★₁ ⊸ ★₀ <: ★₀ ⊸ ★₀" $
let tm1 = Arr One (TYPE 1) (TYPE 0)
tm2 = Arr One (TYPE 0) (TYPE 0) in
subT tm1 tm2,
subT [<] (TYPE 2) tm1 tm2,
testNeq "★₀ ⊸ ★₀ ≢ ★₀ ⇾ ★₁" $
let tm1 = Arr Zero (TYPE 0) (TYPE 0)
tm2 = Arr Zero (TYPE 0) (TYPE 1) in
equalT tm1 tm2,
equalT [<] (TYPE 2) tm1 tm2,
testEq "★₀ ⊸ ★₀ <: ★₀ ⊸ ★₁" $
let tm1 = Arr One (TYPE 0) (TYPE 0)
tm2 = Arr One (TYPE 0) (TYPE 1) in
subT tm1 tm2,
subT [<] (TYPE 2) tm1 tm2,
testEq "★₀ ⊸ ★₀ <: ★₀ ⊸ ★₁" $
let tm1 = Arr One (TYPE 0) (TYPE 0)
tm2 = Arr One (TYPE 0) (TYPE 1) in
subT tm1 tm2
subT [<] (TYPE 2) tm1 tm2
],
"lambda" :- [
testEq "λ x ⇒ [x] ≡ λ x ⇒ [x]" $
equalT (Lam "x" $ TUsed $ BVT 0) (Lam "x" $ TUsed $ BVT 0),
equalT [<] (Arr One (FT "A") (FT "A"))
(Lam "x" $ TUsed $ BVT 0)
(Lam "x" $ TUsed $ BVT 0),
testEq "λ x ⇒ [x] <: λ x ⇒ [x]" $
equalT (Lam "x" $ TUsed $ BVT 0) (Lam "x" $ TUsed $ BVT 0),
subT [<] (Arr One (FT "A") (FT "A"))
(Lam "x" $ TUsed $ BVT 0)
(Lam "x" $ TUsed $ BVT 0),
testEq "λ x ⇒ [x] ≡ λ y ⇒ [y]" $
equalT (Lam "x" $ TUsed $ BVT 0) (Lam "y" $ TUsed $ BVT 0),
equalT [<] (Arr One (FT "A") (FT "A"))
(Lam "x" $ TUsed $ BVT 0)
(Lam "y" $ TUsed $ BVT 0),
testEq "λ x ⇒ [x] <: λ y ⇒ [y]" $
equalT (Lam "x" $ TUsed $ BVT 0) (Lam "y" $ TUsed $ BVT 0),
equalT [<] (Arr One (FT "A") (FT "A"))
(Lam "x" $ TUsed $ BVT 0)
(Lam "y" $ TUsed $ BVT 0),
testNeq "λ x y ⇒ [x] ≢ λ x y ⇒ [y]" $
equalT (Lam "x" $ TUsed $ Lam "y" $ TUsed $ BVT 1)
(Lam "x" $ TUsed $ Lam "y" $ TUsed $ BVT 0),
equalT [<] (Arr One (FT "A") $ Arr One (FT "A") (FT "A"))
(Lam "x" $ TUsed $ Lam "y" $ TUsed $ BVT 1)
(Lam "x" $ TUsed $ Lam "y" $ TUsed $ BVT 0),
testEq "λ x ⇒ [a] ≡ λ x ⇒ [a] (TUsed vs TUnused)" $
equalT (Lam "x" $ TUsed $ FT "a")
(Lam "x" $ TUnused $ FT "a"),
equalT [<] (Arr Zero (FT "B") (FT "A"))
(Lam "x" $ TUsed $ FT "a")
(Lam "x" $ TUnused $ FT "a"),
skipWith "(no η yet)" $
testEq "λ x ⇒ [f [x]] ≡ [f] (η)" $
equalT (Lam "x" $ TUsed $ E $ F "f" :@ BVT 0)
(FT "f")
equalT [<] (Arr One (FT "A") (FT "A"))
(Lam "x" $ TUsed $ E $ F "f" :@ BVT 0)
(FT "f")
],
"eq type" :- [
testEq "(★₀ = ★₀ : ★₁) ≡ (★₀ = ★₀ : ★₁)" $
let tm = Eq0 (TYPE 1) (TYPE 0) (TYPE 0) in
equalT tm tm,
equalT [<] (TYPE 2) tm tm,
testEq "A ≔ ★₁ ⊢ (★₀ = ★₀ : ★₁) ≡ (★₀ = ★₀ : A)"
{globals = fromList [("A", mkDef zero (TYPE 2) (TYPE 1))]} $
equalT (Eq0 (TYPE 1) (TYPE 0) (TYPE 0))
(Eq0 (FT "A") (TYPE 0) (TYPE 0))
equalT [<] (TYPE 2)
(Eq0 (TYPE 1) (TYPE 0) (TYPE 0))
(Eq0 (FT "A") (TYPE 0) (TYPE 0))
],
todo "dim lambda",
@ -178,17 +213,25 @@ tests = "equality & subtyping" :- [
"term closure" :- [
note "𝑖, 𝑗 for bound variables pointing outside of the current expr",
testEq "[𝑖]{} ≡ [𝑖]" $
equalT (CloT (BVT 0) id) (BVT 0) {n = 1},
equalT [< FT "A"] (FT "A") {n = 1}
(CloT (BVT 0) id)
(BVT 0),
testEq "[𝑖]{a/𝑖} ≡ [a]" $
equalT (CloT (BVT 0) (F "a" ::: id)) (FT "a"),
equalT [<] (FT "A")
(CloT (BVT 0) (F "a" ::: id))
(FT "a"),
testEq "[𝑖]{a/𝑖,b/𝑗} ≡ [a]" $
equalT (CloT (BVT 0) (F "a" ::: F "b" ::: id)) (FT "a"),
equalT [<] (FT "A")
(CloT (BVT 0) (F "a" ::: F "b" ::: id))
(FT "a"),
testEq "(λy. [𝑖]){y/y, a/𝑖} ≡ λy. [a] (TUnused)" $
equalT (CloT (Lam "y" $ TUnused $ BVT 0) (F "a" ::: id))
(Lam "y" $ TUnused $ FT "a"),
equalT [<] (Arr Zero (FT "B") (FT "A"))
(CloT (Lam "y" $ TUnused $ BVT 0) (F "a" ::: id))
(Lam "y" $ TUnused $ FT "a"),
testEq "(λy. [𝑖]){y/y, a/𝑖} ≡ λy. [a] (TUsed)" $
equalT (CloT (Lam "y" $ TUsed $ BVT 1) (F "a" ::: id))
(Lam "y" $ TUsed $ FT "a")
equalT [<] (Arr Zero (FT "B") (FT "A"))
(CloT (Lam "y" $ TUsed $ BVT 1) (F "a" ::: id))
(Lam "y" $ TUsed $ FT "a")
],
todo "term d-closure",
@ -202,73 +245,74 @@ tests = "equality & subtyping" :- [
("B", mkDef Any (TYPE (U 1)) (FT "A"))]
in [
testEq "A ≡ A" $
equalE (F "A") (F "A"),
equalE [<] (F "A") (F "A"),
testNeq "A ≢ B" $
equalE (F "A") (F "B"),
equalE [<] (F "A") (F "B"),
testEq "0=1 ⊢ A ≡ B" $
equalE {eqs = ZeroIsOne} (F "A") (F "B"),
equalE {eqs = ZeroIsOne} [<] (F "A") (F "B"),
testEq "A : ★₁ ≔ ★₀ ⊢ A ≡ (★₀ ∷ ★₁)" {globals = au_bu} $
equalE (F "A") (TYPE 0 :# TYPE 1),
equalE [<] (F "A") (TYPE 0 :# TYPE 1),
testEq "A ≔ ★₀, B ≔ ★₀ ⊢ A ≡ B" {globals = au_bu} $
equalE (F "A") (F "B"),
equalE [<] (F "A") (F "B"),
testEq "A ≔ ★₀, B ≔ A ⊢ A ≡ B" {globals = au_ba} $
equalE (F "A") (F "B"),
equalE [<] (F "A") (F "B"),
testEq "A <: A" $
subE (F "A") (F "A"),
subE [<] (F "A") (F "A"),
testNeq "A ≮: B" $
subE (F "A") (F "B"),
subE [<] (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))]} $
subE (F "A") (F "B"),
subE [<] (F "A") (F "B"),
testEq "A : ★₁👈 ≔ ★₀, B : ★₃ ≔ ★₂ ⊢ A <: B"
{globals = fromList [("A", mkDef Any (TYPE 1) (TYPE 0)),
("B", mkDef Any (TYPE 3) (TYPE 2))]} $
subE (F "A") (F "B"),
subE [<] (F "A") (F "B"),
testEq "0=1 ⊢ A <: B" $
subE (F "A") (F "B") {eqs = ZeroIsOne}
subE [<] (F "A") (F "B") {eqs = ZeroIsOne}
],
"bound var" :- [
note "𝑖, 𝑗 for distinct bound variables",
testEq "𝑖𝑖" $
equalE (BV 0) (BV 0) {n = 1},
equalE [< TYPE 0] (BV 0) (BV 0) {n = 1},
testNeq "𝑖𝑗" $
equalE (BV 0) (BV 1) {n = 2},
equalE [< TYPE 0, TYPE 0] (BV 0) (BV 1) {n = 2},
testEq "0=1 ⊢ 𝑖𝑗" $
equalE {n = 2, eqs = ZeroIsOne} (BV 0) (BV 1)
equalE [< TYPE 0, TYPE 0] (BV 0) (BV 1)
{n = 2, eqs = ZeroIsOne}
],
"application" :- [
testEq "f [a] ≡ f [a]" $
equalE (F "f" :@ FT "a") (F "f" :@ FT "a"),
equalE [<] (F "f" :@ FT "a") (F "f" :@ FT "a"),
testEq "f [a] <: f [a]" $
subE (F "f" :@ FT "a") (F "f" :@ FT "a"),
subE [<] (F "f" :@ FT "a") (F "f" :@ FT "a"),
testEq "(λ x ⇒ [x] ∷ A ⊸ A) a ≡ ([a ∷ A] ∷ A) (β)" $
equalE
equalE [<]
((Lam "x" (TUsed (BVT 0)) :# (Arr One (FT "A") (FT "A")))
:@ FT "a")
(E (FT "a" :# FT "A") :# FT "A"),
testEq "(λ x ⇒ [x] ∷ A ⊸ A) a ≡ a (βυ)" $
equalE
equalE [<]
((Lam "x" (TUsed (BVT 0)) :# (Arr One (FT "A") (FT "A")))
:@ FT "a")
(F "a"),
testEq "(λ g ⇒ [g [x]] ∷ ⋯)) [f] ≡ (λ y ⇒ [f [y]] ∷ ⋯) [x] (β↘↙)" $
testEq "(λ g ⇒ [g [a]] ∷ ⋯)) [f] ≡ (λ y ⇒ [f [y]] ∷ ⋯) [a] (β↘↙)" $
let a = FT "A"; a2a = (Arr One a a) in
equalE
((Lam "g" (TUsed (E (BV 0 :@ FT "x"))) :# Arr One a2a a) :@ FT "f")
((Lam "y" (TUsed (E (F "f" :@ BVT 0))) :# a2a) :@ FT "x"),
equalE [<]
((Lam "g" (TUsed (E (BV 0 :@ FT "a"))) :# Arr One a2a a) :@ FT "f")
((Lam "y" (TUsed (E (F "f" :@ BVT 0))) :# a2a) :@ FT "a"),
testEq "(λ x ⇒ [x] ∷ A ⊸ A) a <: a" $
subE
subE [<]
((Lam "x" (TUsed (BVT 0)) :# (Arr One (FT "A") (FT "A")))
:@ FT "a")
(F "a"),
testEq "f : A ⊸ A ≔ λ x ⇒ [x] ⊢ f [x] ≡ x"
{globals = fromList
[("f", mkDef Any (Arr One (FT "A") (FT "A"))
testEq "id : A ⊸ A ≔ λ x ⇒ [x] ⊢ id [a] ≡ a"
{globals = defGlobals `mergeLeft` fromList
[("id", mkDef Any (Arr One (FT "A") (FT "A"))
(Lam "x" (TUsed (BVT 0))))]} $
equalE (F "f" :@ FT "x") (F "x")
equalE [<] (F "id" :@ FT "a") (F "a")
],
"dim application" :-
@ -277,13 +321,16 @@ tests = "equality & subtyping" :- [
in
[
note #""refl [A] x" is an abbreviation for "(λᴰi ⇒ x)(x ≡ x : A)""#,
testEq "refl [A] x ≡ refl [A] x" $
equalE (refl (FT "A") (FT "x")) (refl (FT "A") (FT "x")),
testEq "refl [A] a ≡ refl [A] a" $
equalE [<] (refl (FT "A") (FT "a")) (refl (FT "A") (FT "a")),
testEq "p : (a ≡ b : A), q : (a ≡ b : A) ⊢ p ≡ q"
{globals =
let def = mkAbstract Zero $ Eq0 (FT "A") (FT "a") (FT "b") in
fromList [("p", def), ("q", def)]} $
equalE (F "p") (F "q")
fromList [("A", mkAbstract Zero $ TYPE 0),
("a", mkAbstract Any $ FT "A"),
("b", mkAbstract Any $ FT "A"),
("p", def), ("q", def)]} $
equalE [<] (F "p") (F "q")
],
todo "annotation",
@ -294,9 +341,10 @@ tests = "equality & subtyping" :- [
"clashes" :- [
testNeq "★₀ ≢ ★₀ ⇾ ★₀" $
equalT (TYPE 0) (Arr Zero (TYPE 0) (TYPE 0)),
equalT [<] (TYPE 1) (TYPE 0) (Arr Zero (TYPE 0) (TYPE 0)),
testEq "0=1 ⊢ ★₀ ≡ ★₀ ⇾ ★₀" $
equalT (TYPE 0) (Arr Zero (TYPE 0) (TYPE 0)) {eqs = ZeroIsOne},
equalT [<] (TYPE 1) (TYPE 0) (Arr Zero (TYPE 0) (TYPE 0))
{eqs = ZeroIsOne},
todo "others"
]
]

View file

@ -27,16 +27,16 @@ testNoStep whnf label e = test "\{label} (no step)" $
parameters {default empty defs : Definitions Three} {default 0 d, n : Nat}
testWhnfT : String -> Term Three d n -> Term Three d n -> Test
testWhnfT = testWhnf (whnf defs)
testWhnfT = testWhnf (whnfD defs)
testWhnfE : String -> Elim Three d n -> Elim Three d n -> Test
testWhnfE = testWhnf (whnf defs)
testWhnfE = testWhnf (whnfD defs)
testNoStepE : String -> Elim Three d n -> Test
testNoStepE = testNoStep (whnf defs)
testNoStepE = testNoStep (whnfD defs)
testNoStepT : String -> Term Three d n -> Test
testNoStepT = testNoStep (whnf defs)
testNoStepT = testNoStep (whnfD defs)
tests = "whnf" :- [