pair stuff

tests/TermImpls.idr

@@ -5,20 +5,18 @@ import public Quox.Pretty
 
 
 private
-eqShift : Shift from1 to -> Shift from2 to -> Maybe (from1 = from2)
-eqShift SZ      SZ      = Just Refl
-eqShift (SS by) (SS bz) = eqShift by bz
-eqShift SZ      (SS by) = Nothing
-eqShift (SS by) SZ      = Nothing
+eqShiftLen : Shift from1 to -> Shift from2 to -> Maybe (from1 = from2)
+eqShiftLen SZ      SZ      = Just Refl
+eqShiftLen (SS by) (SS bz) = eqShiftLen by bz
+eqShiftLen _       _       = Nothing
 
 private
-eqSubst : Subst tm1 from1 to -> Subst tm2 from2 to -> Maybe (from1 = from2)
-eqSubst (Shift by) (Shift bz) = eqShift by bz
-eqSubst (_ ::: th) (_ ::: ph) = cong S <$> eqSubst th ph
-eqSubst (Shift _)  (_ ::: _)  = Nothing
-eqSubst (_ ::: _)  (Shift _)  = Nothing
-  -- maybe from1 = from2 in the last two cases, but this is for
-  -- (==), and they're not equal, so who cares
+eqSubstLen : Subst tm1 from1 to -> Subst tm2 from2 to -> Maybe (from1 = from2)
+eqSubstLen (Shift by) (Shift bz) = eqShiftLen by bz
+eqSubstLen (_ ::: th) (_ ::: ph) = cong S <$> eqSubstLen th ph
+eqSubstLen _          _          = Nothing
+  -- maybe from1 = from2 in the last case, but this is for
+  -- (==), and the substs aren't equal, so who cares
 
 mutual
   export covering
@@ -33,6 +31,12 @@ mutual
     Lam _ body1 == Lam _ body2 = body1 == body2
     Lam {} == _ = False
 
+    Sig _ fst1 snd1 == Sig _ fst2 snd2 = fst1 == fst2 && snd1 == snd2
+    Sig {} == _ = False
+
+    Pair fst1 snd1 == Pair fst2 snd2 = fst1 == fst2 && snd1 == snd2
+    Pair {} == _ = False
+
     Eq _ ty1 l1 r1 == Eq _ ty2 l2 r2 =
       ty1 == ty2 && l1 == l2 && r1 == r2
     Eq {} == _ = False
@@ -44,13 +48,13 @@ mutual
     E _ == _ = False
 
     CloT tm1 th1 == CloT tm2 th2 =
-      case eqSubst th1 th2 of
+      case eqSubstLen th1 th2 of
            Just Refl => tm1 == tm2 && th1 == th2
            Nothing   => False
     CloT {} == _ = False
 
     DCloT tm1 th1 == DCloT tm2 th2 =
-      case eqSubst th1 th2 of
+      case eqSubstLen th1 th2 of
            Just Refl => tm1 == tm2 && th1 == th2
            Nothing   => False
     DCloT {} == _ = False
@@ -66,33 +70,37 @@ mutual
     (fun1 :@ arg1) == (fun2 :@ arg2) = fun1 == fun2 && arg1 == arg2
     (_ :@ _) == _ = False
 
-    (tm1 :# ty1) == (tm2 :# ty2) = tm1 == tm2 && ty1 == ty2
-    (_ :# _) == _ = False
+    CasePair q1 p1 _ r1 _ _ b1 == CasePair q2 p2 _ r2 _ _ b2 =
+      q1 == q2 && p1 == p2 && r1 == r2 && b1 == b2
+    CasePair {} == _ = False
 
     (fun1 :% dim1) == (fun2 :% dim2) = fun1 == fun2 && dim1 == dim2
     (_ :% _) == _ = False
 
+    (tm1 :# ty1) == (tm2 :# ty2) = tm1 == tm2 && ty1 == ty2
+    (_ :# _) == _ = False
+
     CloE el1 th1 == CloE el2 th2 =
-      case eqSubst th1 th2 of
+      case eqSubstLen th1 th2 of
            Just Refl => el1 == el2 && th1 == th2
            Nothing   => False
     CloE {} == _ = False
 
     DCloE el1 th1 == DCloE el2 th2 =
-      case eqSubst th1 th2 of
+      case eqSubstLen th1 th2 of
            Just Refl => el1 == el2 && th1 == th2
            Nothing   => False
     DCloE {} == _ = False
 
   export covering
-  Eq q => Eq (ScopeTerm q d n) where
+  Eq q => Eq (ScopeTermN s q d n) where
     TUsed   s == TUsed   t = s == t
     TUnused s == TUnused t = s == t
     TUsed   _ == TUnused _ = False
     TUnused _ == TUsed   _ = False
 
   export covering
-  Eq q => Eq (DScopeTerm q d n) where
+  Eq q => Eq (DScopeTermN s q d n) where
     DUsed   s == DUsed   t = s == t
     DUnused s == DUnused t = s == t
     DUsed   _ == DUnused _ = False

tests/Tests/Equal.idr

@@ -16,6 +16,9 @@ ToInfo (Error Three) where
   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)]
@@ -139,16 +142,6 @@ tests = "equality & subtyping" :- [
       subT tm1 tm2
   ],
 
-  "eq type" :- [
-    testEq "(★₀ = ★₀ : ★₁) ≡ (★₀ = ★₀ : ★₁)" $
-      let tm = Eq0 (TYPE 1) (TYPE 0) (TYPE 0) in
-      equalT 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))
-  ],
-
   "lambda" :- [
     testEq "λ x ⇒ [x] ≡ λ x ⇒ [x]" $
       equalT (Lam "x" $ TUsed $ BVT 0) (Lam "x" $ TUsed $ BVT 0),
@@ -170,6 +163,18 @@ tests = "equality & subtyping" :- [
              (FT "f")
   ],
 
+  "eq type" :- [
+    testEq "(★₀ = ★₀ : ★₁) ≡ (★₀ = ★₀ : ★₁)" $
+      let tm = Eq0 (TYPE 1) (TYPE 0) (TYPE 0) in
+      equalT 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))
+  ],
+
+  todo "dim lambda",
+
   "term closure" :- [
     note "𝑖, 𝑗 for bound variables pointing outside of the current expr",
     testEq "[𝑖]{} ≡ [𝑖]" $
@@ -266,6 +271,21 @@ tests = "equality & subtyping" :- [
       equalE (F "f" :@ FT "x") (F "x")
   ],
 
+  "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] x ≡ refl [A] x" $
+      equalE (refl (FT "A") (FT "x")) (refl (FT "A") (FT "x")),
+    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")
+  ],
+
   todo "annotation",
 
   todo "elim closure",

tests/quox-tests.ipkg

@@ -4,3 +4,7 @@ depends = base, contrib, elab-util, sop, snocvect, quox-lib, tap
 
 executable = quox-tests
 main = Tests
+modules =
+  TermImpls,
+  Tests.Reduce,
+  Tests.Equal