quox/tests/Tests/Equal.idr

module Tests.Equal

import Quox.Equal as Lib
import Quox.Pretty
import Quox.Syntax.Qty.Three
import TAP

export
ToInfo (Error Three) 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 (ExpectedSig t) =
    [("type", "ExpectedSig"),
     ("got", prettyStr True t)]
  toInfo (ExpectedEq t) =
    [("type", "ExpectedEq"),
     ("got", prettyStr True t)]
  toInfo (BadUniverse k l) =
    [("type", "BadUniverse"),
     ("low",  show k),
     ("high", show l)]
  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),
     ("left",  prettyStr True k),
     ("right", prettyStr True l)]
  toInfo (ClashQ pi rh) =
    [("type", "ClashQ"),
     ("left",  prettyStr True pi),
     ("right", prettyStr True rh)]
  toInfo (ClashD p q) =
    [("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 defGlobals globals : Definitions Three}
  testEq : Test
  testEq = test label $ runReaderT globals act

  testNeq : Test
  testNeq = testThrows label (const True) $ runReaderT globals act


parameters {default 0   d, n : Nat}
           {default new eqs  : DimEq d}
           (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 -> 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 eqs ctx e f

  equalE : Elim Three d n -> Elim Three d n -> M ()
  equalE e f = Elim.equal eqs ctx e f


export
tests : Test
tests = "equality & subtyping" :- [
  note #""0=1 ⊢ 𝒥" means that 𝒥 holds in an inconsistent dim context"#,

  "universes" :- [
    testEq "★₀ ≡ ★₀" $
      equalT [<] (TYPE 1) (TYPE 0) (TYPE 0),
    testNeq "★₀ ≢ ★₁" $
      equalT [<] (TYPE 2) (TYPE 0) (TYPE 1),
    testNeq "★₁ ≢ ★₀" $
      equalT [<] (TYPE 2) (TYPE 1) (TYPE 0),
    testEq "★₀ <: ★₀" $
      subT [<] (TYPE 1) (TYPE 0) (TYPE 0),
    testEq "★₀ <: ★₁" $
      subT [<] (TYPE 2) (TYPE 0) (TYPE 1),
    testNeq "★₁ ≮: ★₀" $
      subT [<] (TYPE 2) (TYPE 1) (TYPE 0)
  ],

  "pi" :- [
    note #""A ⊸ B" for (1 _ : A) → B"#,
    note #""A ⇾ B" for (0 _ : A) → B"#,
    testEq "A ⊸ B ≡ A ⊸ B" $
      let tm = Arr One (FT "A") (FT "B") in
      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 [<] (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 [<] (TYPE 0) tm1 tm2 {eqs = ZeroIsOne},
    testEq "A ⊸ B <: A ⊸ B" $
      let tm = Arr One (FT "A") (FT "B") in
      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 [<] (TYPE 0) tm1 tm2,
    testEq "★₀ ⇾ ★₀ ≡ ★₀ ⇾ ★₀" $
      let tm = Arr Zero (TYPE 0) (TYPE 0) in
      equalT [<] (TYPE 1) tm tm,
    testEq "★₀ ⇾ ★₀ <: ★₀ ⇾ ★₀" $
      let tm = Arr Zero (TYPE 0) (TYPE 0) in
      subT [<] (TYPE 1) tm tm,
    testNeq "★₁ ⊸ ★₀ ≢ ★₀ ⇾ ★₀" $
      let tm1 = Arr Zero (TYPE 1) (TYPE 0)
          tm2 = Arr Zero (TYPE 0) (TYPE 0) in
      equalT [<] (TYPE 2) tm1 tm2,
    testEq "★₁ ⊸ ★₀ <: ★₀ ⊸ ★₀" $
      let tm1 = Arr One (TYPE 1) (TYPE 0)
          tm2 = Arr One (TYPE 0) (TYPE 0) in
      subT [<] (TYPE 2) tm1 tm2,
    testNeq "★₀ ⊸ ★₀ ≢ ★₀ ⇾ ★₁" $
      let tm1 = Arr Zero (TYPE 0) (TYPE 0)
          tm2 = Arr Zero (TYPE 0) (TYPE 1) in
      equalT [<] (TYPE 2) tm1 tm2,
    testEq "★₀ ⊸ ★₀ <: ★₀ ⊸ ★₁" $
      let tm1 = Arr One (TYPE 0) (TYPE 0)
          tm2 = Arr One (TYPE 0) (TYPE 1) in
      subT [<] (TYPE 2) tm1 tm2,
    testEq "★₀ ⊸ ★₀ <: ★₀ ⊸ ★₁" $
      let tm1 = Arr One (TYPE 0) (TYPE 0)
          tm2 = Arr One (TYPE 0) (TYPE 1) in
      subT [<] (TYPE 2) tm1 tm2
  ],

  "lambda" :- [
    testEq "λ x ⇒ [x] ≡ λ x ⇒ [x]" $
      equalT [<] (Arr One (FT "A") (FT "A"))
        (Lam "x" $ TUsed $ BVT 0)
        (Lam "x" $ TUsed $ BVT 0),
    testEq "λ x ⇒ [x] <: λ x ⇒ [x]" $
      subT [<] (Arr One (FT "A") (FT "A"))
        (Lam "x" $ TUsed $ BVT 0)
        (Lam "x" $ TUsed $ BVT 0),
    testEq "λ x ⇒ [x] ≡ λ y ⇒ [y]" $
      equalT [<] (Arr One (FT "A") (FT "A"))
        (Lam "x" $ TUsed $ BVT 0)
        (Lam "y" $ TUsed $ BVT 0),
    testEq "λ x ⇒ [x] <: λ y ⇒ [y]" $
      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 [<] (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 [<] (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 [<] (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 [<] (TYPE 2) tm tm,
    testEq "A ≔ ★₁ ⊢ (★₀ = ★₀ : ★₁) ≡ (★₀ = ★₀ : A)"
        {globals = fromList [("A", mkDef zero (TYPE 2) (TYPE 1))]} $
      equalT [<] (TYPE 2)
        (Eq0 (TYPE 1) (TYPE 0) (TYPE 0))
        (Eq0 (FT "A") (TYPE 0) (TYPE 0))
  ],

  todo "dim lambda",

  "term closure" :- [
    note "𝑖, 𝑗 for bound variables pointing outside of the current expr",
    testEq "[𝑖]{} ≡ [𝑖]" $
      equalT [< FT "A"] (FT "A") {n = 1}
        (CloT (BVT 0) id)
        (BVT 0),
    testEq "[𝑖]{a/𝑖} ≡ [a]" $
      equalT [<] (FT "A")
        (CloT (BVT 0) (F "a" ::: id))
        (FT "a"),
    testEq "[𝑖]{a/𝑖,b/𝑗} ≡ [a]" $
      equalT [<] (FT "A")
        (CloT (BVT 0) (F "a" ::: F "b" ::: id))
        (FT "a"),
    testEq "(λy. [𝑖]){y/y, a/𝑖} ≡ λy. [a]  (TUnused)" $
      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 [<] (Arr Zero (FT "B") (FT "A"))
        (CloT (Lam "y" $ TUsed $ BVT 1) (F "a" ::: id))
        (Lam "y" $ TUsed $ FT "a")
  ],

  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 [
    testEq "A ≡ A" $
      equalE [<] (F "A") (F "A"),
    testNeq "A ≢ B" $
      equalE [<] (F "A") (F "B"),
    testEq "0=1 ⊢ A ≡ B" $
      equalE {eqs = ZeroIsOne} [<] (F "A") (F "B"),
    testEq "A : ★₁ ≔ ★₀ ⊢ A ≡ (★₀ ∷ ★₁)" {globals = au_bu} $
      equalE [<] (F "A") (TYPE 0 :# TYPE 1),
    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"),
    testEq "A <: A" $
      subE [<] (F "A") (F "A"),
    testNeq "A ≮: 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"),
    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"),
    testEq "0=1 ⊢ A <: B" $
      subE [<] (F "A") (F "B") {eqs = ZeroIsOne}
  ],

  "bound var" :- [
    note "𝑖, 𝑗 for distinct bound variables",
    testEq "𝑖 ≡ 𝑖" $
      equalE [< TYPE 0] (BV 0) (BV 0) {n = 1},
    testNeq "𝑖 ≢ 𝑗" $
      equalE [< TYPE 0, TYPE 0] (BV 0) (BV 1) {n = 2},
    testEq "0=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"),
    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 "(λ 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 "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 [<]
        ((Lam "x" (TUsed (BVT 0)) :# (Arr One (FT "A") (FT "A")))
          :@ FT "a")
        (F "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 "id" :@ FT "a") (F "a")
  ],

  "dim application" :-
  let refl : Term q d n -> Term q d n -> Elim q d n
      refl a x = (DLam "_" $ DUnused x) :# (Eq0 a x x)
  in
  [
    note #""refl [A] x" is an abbreviation for "(λᴰi ⇒ x) ∷ (x ≡ x : A)""#,
    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 [("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",

  todo "elim closure",

  todo "elim d-closure",

  "clashes" :- [
    testNeq "★₀ ≢ ★₀ ⇾ ★₀" $
      equalT [<] (TYPE 1) (TYPE 0) (Arr Zero (TYPE 0) (TYPE 0)),
    testEq "0=1 ⊢ ★₀ ≡ ★₀ ⇾ ★₀" $
      equalT [<] (TYPE 1) (TYPE 0) (Arr Zero (TYPE 0) (TYPE 0))
        {eqs = ZeroIsOne},
    todo "others"
  ]
]