minor refactor

lib/Quox/Equal.idr

@@ -30,6 +30,10 @@ export %inline
 mode : Has EqModeState fs => Eff fs EqMode
 mode = get
 
+private %inline
+withEqual : Has EqModeState fs => Eff fs a -> Eff fs a
+withEqual = local_ Equal
+
 
 parameters (loc : Loc) (ctx : EqContext n)
   private %inline
@@ -242,7 +246,7 @@ namespace Term
       (E _, _)   => wrongType t.loc ctx ty t
       _          => wrongType s.loc ctx ty s
 
-  compare0' defs ctx sg ty@(Pi {qty, arg, res, _}) s t = local_ Equal $
+  compare0' defs ctx sg ty@(Pi {qty, arg, res, _}) s t = withEqual $
     --              Γ ⊢ A empty
     -- -------------------------------------------
     --  Γ ⊢ (λ x ⇒ s) = (λ x ⇒ t) ⇐ (π·x : A) → B
@@ -276,7 +280,7 @@ namespace Term
     eta loc e (S _ (N _)) = clashT loc ctx ty s t
     eta _   e (S _ (Y b)) = compare0 defs ctx' sg res.term (toLamBody e) b
 
-  compare0' defs ctx sg ty@(Sig {fst, snd, _}) s t = local_ Equal $
+  compare0' defs ctx sg ty@(Sig {fst, snd, _}) s t = withEqual $
     case (s, t) of
       --  Γ ⊢ s₁ = t₁ ⇐ A     Γ ⊢ s₂ = t₂ ⇐ B{s₁/x}
       -- --------------------------------------------
@@ -302,7 +306,7 @@ namespace Term
           compare0 defs ctx sg (sub1 snd (Ann s fst s.loc)) (E $ Snd e e.loc) t
         SOne => clashT loc ctx ty s t
 
-  compare0' defs ctx sg ty@(Enum cases _) s t = local_ Equal $
+  compare0' defs ctx sg ty@(Enum cases _) s t = withEqual $
     -- η for empty & singleton enums
     if length (SortedSet.toList cases) <= 1 then pure () else
     case (s, t) of
@@ -327,7 +331,7 @@ namespace Term
     --  Γ ⊢ e = f ⇐ Eq [i ⇒ A] s t
     pure ()
 
-  compare0' defs ctx sg nat@(NAT {}) s t = local_ Equal $
+  compare0' defs ctx sg nat@(NAT {}) s t = withEqual $
     case (s, t) of
       -- ---------------
       --  Γ ⊢ n = n ⇐ ℕ
@@ -354,7 +358,7 @@ namespace Term
       (E _,     t) => wrongType t.loc ctx nat t
       (s,       _) => wrongType s.loc ctx nat s
 
-  compare0' defs ctx sg str@(STRING {}) s t = local_ Equal $
+  compare0' defs ctx sg str@(STRING {}) s t = withEqual $
     case (s, t) of
       (Str x _, Str y _) => unless (x == y) $ clashT s.loc ctx str s t
 
@@ -367,7 +371,7 @@ namespace Term
       (E _,    _) => wrongType t.loc ctx str t
       _           => wrongType s.loc ctx str s
 
-  compare0' defs ctx sg bty@(BOX q ty {}) s t = local_ Equal $
+  compare0' defs ctx sg bty@(BOX q ty {}) s t = withEqual $
     case (s, t) of
       --     Γ ⊢ s = t ⇐ A
       -- -----------------------
@@ -445,7 +449,7 @@ compareType' defs ctx (Eq {ty = sTy, l = sl, r = sr, _})
   compareType defs (extendDim sTy.name Zero ctx) sTy.zero tTy.zero
   compareType defs (extendDim sTy.name One  ctx) sTy.one  tTy.one
   ty <- bigger sTy tTy
-  local_ Equal $ do
+  withEqual $ do
     Term.compare0 defs ctx SZero ty.zero sl tl
     Term.compare0 defs ctx SZero ty.one  sr tr
 
@@ -545,8 +549,8 @@ namespace Elim
   try act = lift $ catch putError $ lift act {fs' = EqualElim}
 
   private %inline
-  nested : Eff EqualInner a -> Eff EqualElim (Either Error a)
+  succeeds : Eff EqualInner a -> Eff EqualElim Bool
-  nested act = lift $ runExcept act
+  succeeds act = lift $ map isRight $ runExcept act
 
   private covering %inline
   clashE : (defs : Definitions) -> (ctx : EqContext n) -> (sg : SQty) ->
@@ -618,16 +622,14 @@ namespace Elim
   --  Ψ | Γ ⊢ coe (𝑖 ⇒ A) @p @q s ⇝ (s ∷ A‹1/𝑖›) ⇒ A‹1/𝑖›
   --
   -- it's here so that whnf doesn't have to depend on the equality checker
-  compare0Inner' defs ctx sg (Coe ty p q val loc) f _ _ = do
+  compare0Inner' defs ctx sg (Coe ty p q val loc) f _ _ =
-    tyEq <- nested $ local_ Equal $ compareType defs ctx ty.zero ty.one
+    if !(succeeds $ withEqual $ compareType defs ctx ty.zero ty.one)
-    if isRight tyEq
        then compare0Inner defs ctx sg (Ann val (dsub1 ty q) loc) f
        else clashE defs ctx sg (Coe ty p q val loc) f
 
   -- symmetric version of the above
-  compare0Inner' defs ctx sg e (Coe ty p q val loc) _ _ = do
+  compare0Inner' defs ctx sg e (Coe ty p q val loc) _ _ =
-    tyEq <- nested $ local_ Equal $ compareType defs ctx ty.zero ty.one
+    if !(succeeds $ withEqual $ compareType defs ctx ty.zero ty.one)
-    if isRight tyEq
        then compare0Inner defs ctx sg e (Ann val (dsub1 ty q) loc)
        else clashE defs ctx sg e (Coe ty p q val loc)
 
@@ -659,7 +661,7 @@ namespace Elim
   --          = caseπ f return R of { (x, y) ⇒ t } ⇒ Q[e/p]
   compare0Inner' defs ctx sg (CasePair epi e eret ebody eloc)
                              (CasePair fpi f fret fbody floc) ne nf =
-    local_ Equal $ do
+    withEqual $ do
       ety <- compare0Inner defs ctx sg e f
       (fst, snd) <- expectSig defs ctx sg eloc ety
       let [< x, y] = ebody.names
@@ -678,7 +680,7 @@ namespace Elim
   -- ------------------------------
   --  Ψ | Γ ⊢ fst e = fst f ⇒ A
   compare0Inner' defs ctx sg (Fst e eloc) (Fst f floc) ne nf =
-    local_ Equal $ do
+    withEqual $ do
       ety <- compare0Inner defs ctx sg e f
       fst <$> expectSig defs ctx sg eloc ety
   compare0Inner' defs ctx sg e@(Fst {}) f _ _ =
@@ -688,7 +690,7 @@ namespace Elim
   -- ------------------------------------
   --  Ψ | Γ ⊢ snd e = snd f ⇒ B[fst e/x]
   compare0Inner' defs ctx sg (Snd e eloc) (Snd f floc) ne nf =
-    local_ Equal $ do
+    withEqual $ do
       ety <- compare0Inner defs ctx sg e f
       (_, tsnd) <- expectSig defs ctx sg eloc ety
       pure $ sub1 tsnd (Fst e eloc)
@@ -703,7 +705,7 @@ namespace Elim
   --        = caseπ f return R of { '𝐚ᵢ ⇒ tᵢ } ⇒ Q[e/x]
   compare0Inner' defs ctx sg (CaseEnum epi e eret earms eloc)
                              (CaseEnum fpi f fret farms floc) ne nf =
-    local_ Equal $ do
+    withEqual $ do
       ety <- compare0Inner defs ctx sg e f
       try $
         compareType defs (extendTy0 eret.name ety ctx) eret.term fret.term
@@ -726,7 +728,7 @@ namespace Elim
   --        ⇒ Q[e/x]
   compare0Inner' defs ctx sg (CaseNat epi epi' e eret ezer esuc eloc)
                              (CaseNat fpi fpi' f fret fzer fsuc floc) ne nf =
-    local_ Equal $ do
+    withEqual $ do
       ety <- compare0Inner defs ctx sg e f
       let [< p, ih] = esuc.names
       try $ do
@@ -750,7 +752,7 @@ namespace Elim
   --        = caseπ f return R of { [x] ⇒ t } ⇒ Q[e/x]
   compare0Inner' defs ctx sg (CaseBox epi e eret ebody eloc)
                              (CaseBox fpi f fret fbody floc) ne nf =
-    local_ Equal $ do
+    withEqual $ do
       ety <- compare0Inner defs ctx sg e f
       (q, ty) <- expectBOX defs ctx sg eloc ety
       try $ do
@@ -776,7 +778,7 @@ namespace Elim
   compare0Inner' defs ctx sg (TypeCase ty1 ret1 arms1 def1 eloc)
                              (TypeCase ty2 ret2 arms2 def2 floc) ne _ =
     case sg `decEq` SZero of
-      Yes Refl => local_ Equal $ do
+      Yes Refl => withEqual $ do
         ety <- compare0Inner defs ctx SZero ty1 ty2
         u   <- expectTYPE defs ctx SZero eloc ety
         try $ do