quox/tests/Tests/Equal.idr

225 lines
7 KiB
Idris
Raw Normal View History

2022-04-27 14:06:39 -04:00
module Tests.Equal
2022-05-25 10:10:19 -04:00
import Quox.Equal as Lib
2022-04-27 14:06:39 -04:00
import Quox.Pretty
import TAP
export
ToInfo Error where
toInfo (NotInScope x) =
[("type", "NotInScope"),
("name", show x)]
toInfo (ExpectedTYPE t) =
[("type", "ExpectedTYPE"),
("got", prettyStr True t)]
toInfo (ExpectedPi t) =
[("type", "ExpectedPi"),
("got", prettyStr True t)]
toInfo (BadUniverse k l) =
[("type", "BadUniverse"),
("low", show k),
("high", show l)]
2022-04-27 14:06:39 -04:00
toInfo (ClashT mode s t) =
[("type", "ClashT"),
2022-05-08 14:02:57 -04:00
("mode", show mode),
2022-04-27 14:06:39 -04:00
("left", prettyStr True s),
("right", prettyStr True t)]
toInfo (ClashU mode k l) =
[("type", "ClashU"),
2022-05-08 14:02:57 -04:00
("mode", show mode),
2022-04-27 14:06:39 -04:00
("left", prettyStr True k),
("right", prettyStr True l)]
toInfo (ClashQ pi rh) =
[("type", "ClashQ"),
2022-04-27 14:06:39 -04:00
("left", prettyStr True pi),
("right", prettyStr True rh)]
M = ReaderT Definitions (Either Error)
2022-04-27 14:06:39 -04:00
parameters (label : String) (act : Lazy (M ()))
{default empty globals : Definitions}
testEq : Test
testEq = test label $ runReaderT globals act
2022-04-27 14:06:39 -04:00
testNeq : Test
testNeq = testThrows label (const True) $ runReaderT globals act
2022-04-27 14:06:39 -04:00
subT : {default 0 d, n : Nat} -> Term d n -> Term d n -> M ()
2022-05-25 10:10:19 -04:00
subT = Lib.subT
%hide Lib.subT
2022-04-27 14:06:39 -04:00
equalT : {default 0 d, n : Nat} -> Term d n -> Term d n -> M ()
2022-05-25 10:10:19 -04:00
equalT = Lib.equalT
%hide Lib.equalT
2022-04-27 14:06:39 -04:00
subE : {default 0 d, n : Nat} -> Elim d n -> Elim d n -> M ()
2022-05-25 10:10:19 -04:00
subE = Lib.subE
%hide Lib.subE
2022-04-27 14:06:39 -04:00
equalE : {default 0 d, n : Nat} -> Elim d n -> Elim d n -> M ()
2022-05-25 10:10:19 -04:00
equalE = Lib.equalE
%hide Lib.equalE
2022-04-27 14:06:39 -04:00
export
tests : Test
tests = "equality & subtyping" :- [
"universes" :- [
2022-05-09 12:31:43 -04:00
testEq "★₀ ≡ ★₀" $
equalT (TYPE 0) (TYPE 0),
testNeq "★₀ ≢ ★₁" $
equalT (TYPE 0) (TYPE 1),
testNeq "★₁ ≢ ★₀" $
equalT (TYPE 1) (TYPE 0),
testEq "★₀ <: ★₀" $
subT (TYPE 0) (TYPE 0),
testEq "★₀ <: ★₁" $
subT (TYPE 0) (TYPE 1),
testNeq "★₁ ≮: ★₀" $
subT (TYPE 1) (TYPE 0)
],
2022-05-08 14:02:57 -04:00
"pi" :- [
-- ⊸ for →₁, ⇾ for →₀
testEq "A ⊸ B ≡ A ⊸ B" $
let tm = Arr One (FT "A") (FT "B") in
equalT 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,
testEq "A ⊸ B <: A ⊸ B" $
let tm = Arr One (FT "A") (FT "B") in
subT 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,
2022-05-08 22:30:37 -04:00
testEq "★₀ ⇾ ★₀ ≡ ★₀ ⇾ ★₀" $
2022-05-08 14:02:57 -04:00
let tm = Arr Zero (TYPE 0) (TYPE 0) in
equalT tm tm,
2022-05-08 22:30:37 -04:00
testEq "★₀ ⇾ ★₀ <: ★₀ ⇾ ★₀" $
2022-05-08 14:02:57 -04:00
let tm = Arr Zero (TYPE 0) (TYPE 0) in
subT tm tm,
2022-05-08 22:30:37 -04:00
testNeq "★₁ ⊸ ★₀ ≢ ★₀ ⇾ ★₀" $
2022-05-08 14:02:57 -04:00
let tm1 = Arr Zero (TYPE 1) (TYPE 0)
tm2 = Arr Zero (TYPE 0) (TYPE 0) in
equalT tm1 tm2,
2022-05-08 22:30:37 -04:00
testEq "★₁ ⊸ ★₀ <: ★₀ ⊸ ★₀" $
2022-05-08 14:02:57 -04:00
let tm1 = Arr One (TYPE 1) (TYPE 0)
tm2 = Arr One (TYPE 0) (TYPE 0) in
subT tm1 tm2,
2022-05-08 22:30:37 -04:00
testNeq "★₀ ⊸ ★₀ ≢ ★₀ ⇾ ★₁" $
2022-05-08 14:02:57 -04:00
let tm1 = Arr Zero (TYPE 0) (TYPE 0)
tm2 = Arr Zero (TYPE 0) (TYPE 1) in
equalT tm1 tm2,
2022-05-08 22:30:37 -04:00
testEq "★₀ ⊸ ★₀ <: ★₀ ⊸ ★₁" $
2022-05-08 14:02:57 -04:00
let tm1 = Arr One (TYPE 0) (TYPE 0)
tm2 = Arr One (TYPE 0) (TYPE 1) in
subT tm1 tm2,
2022-05-08 22:30:37 -04:00
testEq "★₀ ⊸ ★₀ <: ★₀ ⊸ ★₁" $
2022-05-08 14:02:57 -04:00
let tm1 = Arr One (TYPE 0) (TYPE 0)
tm2 = Arr One (TYPE 0) (TYPE 1) in
subT tm1 tm2
],
"lambda" :- [
testEq "λ x ⇒ [x] ≡ λ x ⇒ [x]" $
2022-05-25 10:10:19 -04:00
equalT (Lam "x" $ TUsed $ BVT 0) (Lam "x" $ TUsed $ BVT 0),
2022-05-08 14:02:57 -04:00
testEq "λ x ⇒ [x] <: λ x ⇒ [x]" $
2022-05-25 10:10:19 -04:00
equalT (Lam "x" $ TUsed $ BVT 0) (Lam "x" $ TUsed $ BVT 0),
2022-05-08 14:02:57 -04:00
testEq "λ x ⇒ [x] ≡ λ y ⇒ [y]" $
2022-05-25 10:10:19 -04:00
equalT (Lam "x" $ TUsed $ BVT 0) (Lam "y" $ TUsed $ BVT 0),
2022-05-08 14:02:57 -04:00
testEq "λ x ⇒ [x] <: λ y ⇒ [y]" $
2022-05-25 10:10:19 -04:00
equalT (Lam "x" $ TUsed $ BVT 0) (Lam "y" $ TUsed $ BVT 0),
2022-05-08 14:02:57 -04:00
testNeq "λ x y ⇒ [x] ≢ λ x y ⇒ [y]" $
2022-05-25 10:10:19 -04:00
equalT (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")
2022-05-08 14:02:57 -04:00
],
2022-05-25 10:10:19 -04:00
"term closure" :- [
testEq "[x]{} ≡ [x]" $
equalT (CloT (BVT 0) id) (BVT 0) {n = 1},
testEq "[x]{a/x} ≡ [a]" $
equalT (CloT (BVT 0) (F "a" ::: id)) (FT "a"),
testEq "[x]{a/x,b/y} ≡ [a]" $
equalT (CloT (BVT 0) (F "a" ::: F "b" ::: id)) (FT "a"),
testEq "(λy. [x]){y/y, a/x} ≡ λy. [a] (TUnused)" $
equalT (CloT (Lam "y" $ TUnused $ BVT 0) (F "a" ::: id))
(Lam "y" $ TUnused $ FT "a"),
testEq "(λy. [x]){y/y, a/x} ≡ λy. [a] (TUsed)" $
equalT (CloT (Lam "y" $ TUsed $ BVT 1) (F "a" ::: id))
(Lam "y" $ TUsed $ FT "a")
],
2022-05-08 14:02:57 -04:00
2022-04-27 14:06:39 -04:00
todo "term d-closure",
"free var" :-
let au_bu = fromList
[("A", MkDef Any (TYPE (U 1)) (TYPE (U 0))),
("B", MkDef Any (TYPE (U 1)) (TYPE (U 0)))]
au_ba = fromList
[("A", MkDef Any (TYPE (U 1)) (TYPE (U 0))),
("B", MkDef Any (TYPE (U 1)) (FT "A"))]
in [
2022-05-09 12:31:43 -04:00
testEq "A ≡ A" $
equalE (F "A") (F "A"),
testNeq "A ≢ B" $
equalE (F "A") (F "B"),
testEq "A ≔ ★₀, B ≔ ★₀ ⊢ A ≡ B" {globals = au_bu} $
equalE (F "A") (F "B"),
testEq "A ≔ ★₀, B ≔ A ⊢ A ≡ B" {globals = au_ba} $
equalE (F "A") (F "B"),
2022-05-09 12:31:43 -04:00
testEq "A <: A" $
subE (F "A") (F "A"),
testNeq "A ≮: B" $
subE (F "A") (F "B")
],
"bound var" :- [
testEq "#0 ≡ #0" $
equalE (BV 0) (BV 0) {n = 1},
testNeq "#0 ≢ #1" $
equalE (BV 0) (BV 1) {n = 2}
],
2022-05-08 14:02:57 -04:00
"application" :- [
2022-05-09 12:31:43 -04:00
testEq "f [a] ≡ f [a]" $
equalE (F "f" :@ FT "a") (F "f" :@ FT "a"),
testEq "f [a] <: f [a]" $
subE (F "f" :@ FT "a") (F "f" :@ FT "a"),
testEq "(λ x ⇒ [x] ∷ A ⊸ A) a ≡ ([a ∷ A] ∷ A) (β)" $
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
((Lam "x" (TUsed (BVT 0)) :# (Arr One (FT "A") (FT "A")))
:@ FT "a")
(F "a"),
testEq "(λ x ⇒ [x] ∷ A ⊸ A) a <: a" $
subE
((Lam "x" (TUsed (BVT 0)) :# (Arr One (FT "A") (FT "A")))
:@ FT "a")
(F "a")
],
2022-05-08 14:02:57 -04:00
2022-04-27 14:06:39 -04:00
todo "annotation",
2022-05-08 14:02:57 -04:00
2022-04-27 14:06:39 -04:00
todo "elim closure",
2022-05-08 14:02:57 -04:00
2022-04-27 14:06:39 -04:00
todo "elim d-closure",
2022-05-08 14:02:57 -04:00
"clashes" :- [
2022-05-08 22:30:37 -04:00
testNeq "★₀ ≢ ★₀ ⇾ ★₀" $
2022-05-08 14:02:57 -04:00
equalT (TYPE 0) (Arr Zero (TYPE 0) (TYPE 0)),
todo "others"
]
2022-04-27 14:06:39 -04:00
]