wrap type errors in extra context

lib/Quox/Equal.idr

@@ -116,7 +116,8 @@ parameters (defs : Definitions' q _) {auto _ : (CanEqual q m, Eq q)}
       ||| ⚠ **assumes that `s`, `t` have already been checked against `ty`**. ⚠
       export covering %inline
       compare0 : TContext q 0 n -> (ty, s, t : Term q 0 n) -> m ()
-      compare0 ctx ty s t = do
+      compare0 ctx ty s t =
+        wrapErr (WhileComparingT (MkTyContext new ctx) !mode ty s t) $ do
           let Element ty nty = whnfD defs ty
               Element s  ns  = whnfD defs s
               Element t  nt  = whnfD defs t
@@ -289,9 +290,9 @@ parameters (defs : Definitions' q _) {auto _ : (CanEqual q m, Eq q)}
       export covering %inline
       compare0 : TContext q 0 n -> (e, f : Elim q 0 n) -> m ()
       compare0 ctx e f =
+        wrapErr (WhileComparingE (MkTyContext new ctx) !mode e f) $ do
           let Element e ne = whnfD defs e
               Element f nf = whnfD defs f
-        in
           -- [fixme] there is a better way to do this "isSubSing" stuff for sure
           unless (isSubSing defs !(computeElimType ctx e ne)) $
             compare0' ctx e f ne nf

lib/Quox/Typechecker.idr

@@ -80,6 +80,7 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m}
   checkC : (ctx : TyContext q d n) -> SQty q -> Term q d n -> Term q d n ->
            m (CheckResult' q n)
   checkC ctx sg subj ty =
+    wrapErr (WhileChecking ctx sg.fst subj ty) $
       let Element subj nc = pushSubsts subj in
       check' ctx sg subj nc ty
 
@@ -104,6 +105,7 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m}
   inferC : (ctx : TyContext q d n) -> SQty q -> Elim q d n ->
            m (InferResult' q d n)
   inferC ctx sg subj =
+    wrapErr (WhileInferring ctx sg.fst subj) $
       let Element subj nc = pushSubsts subj in
       infer' ctx sg subj nc
 

lib/Quox/Typing.idr

@@ -124,10 +124,34 @@ data Error q
 | NotType (Term q d n)
 | WrongType (Term q d n) (Term q d n) (Term q d n)
 
+-- extra context
+| WhileChecking
+    (TyContext q d n) q
+    (Term q d n) -- term
+    (Term q d n) -- type
+    (Error q)
+| WhileInferring
+    (TyContext q d n) q
+    (Elim q d n)
+    (Error q)
+| WhileComparingT
+    (TyContext q d n) EqMode
+    (Term q d n) -- type
+    (Term q d n) (Term q d n) -- lhs/rhs
+    (Error q)
+| WhileComparingE
+    (TyContext q d n) EqMode
+    (Elim q d n) (Elim q d n)
+    (Error q)
+
 public export
 0 HasErr : Type -> (Type -> Type) -> Type
 HasErr q = MonadError (Error q)
 
+export %inline
+wrapErr : HasErr q m => (Error q -> Error q) -> m a -> m a
+wrapErr f act = catchError act $ throwError . f
+
 export %inline
 ucmp : EqMode -> Universe -> Universe -> Bool
 ucmp Equal = (==)

tests/TypingImpls.idr

@@ -58,4 +58,8 @@ PrettyHL q => ToInfo (Error q) where
      ("left",  prettyStr True s),
      ("right", prettyStr True t)]
 
-
+  -- [todo] add nested yamls to TAP and include context here
+  toInfo (WhileChecking   _ _ _ _   err) = toInfo err
+  toInfo (WhileInferring  _ _ _     err) = toInfo err
+  toInfo (WhileComparingT _ _ _ _ _ err) = toInfo err
+  toInfo (WhileComparingE _ _ _ _   err) = toInfo err