%default total

lib/Quox/Parser/FromParser/Error.idr

@@ -7,6 +7,8 @@ import System.File
 
 import Quox.Pretty
 
+%default total
+
 %hide Text.PrettyPrint.Prettyprinter.Doc.infixr.(<++>)
 
 

lib/Quox/Typing/Error.idr

@@ -13,6 +13,8 @@ import Derive.Prelude
 %language ElabReflection
 %hide TT.Name
 
+%default total
+
 
 public export
 record NameContexts d n where
@@ -246,10 +248,26 @@ where
      hangDSingle "with quantities" $
       separateTight !commaD $ toSnocList' !(traverse prettyQty qs)]
 
+parameters {opts : LayoutOpts} (showContext : Bool)
   export
-prettyErrorNoLoc : {opts : _} -> (showContext : Bool) -> Error ->
+  inContext' : Bool -> a -> (a -> Eff Pretty (Doc opts)) ->
-                   Eff Pretty (Doc opts)
+               Doc opts -> Eff Pretty (Doc opts)
-prettyErrorNoLoc showContext = \case
+  inContext' null ctx f doc =
+    if showContext && not null then
+      pure $ vappend doc (sep ["in context", !(f ctx)])
+    else pure doc
+
+  export %inline
+  inTContext : TyContext d n -> Doc opts -> Eff Pretty (Doc opts)
+  inTContext ctx = inContext' (null ctx) ctx prettyTyContext
+
+  export %inline
+  inEContext : EqContext n -> Doc opts -> Eff Pretty (Doc opts)
+  inEContext ctx = inContext' (null ctx) ctx prettyEqContext
+
+  export
+  prettyErrorNoLoc : Error -> Eff Pretty (Doc opts)
+  prettyErrorNoLoc err0 = case err0 of
     ExpectedTYPE _ ctx s =>
       hangDSingle "expected a type universe, but got"
         !(prettyTerm ctx.dnames ctx.tnames s)
@@ -348,14 +366,14 @@ prettyErrorNoLoc showContext = \case
             [hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames s),
              hangDSingle "has type"       !(prettyTerm ctx.dnames ctx.tnames a),
              hangDSingle "with quantity"  !(prettyQty sg.qty)])
-        (prettyErrorNoLoc showContext err)|]
+          (prettyErrorNoLoc err)|]
 
     WhileCheckingTy ctx a k err =>
       [|vappendBlank
           (inTContext ctx . sep =<< sequence
             [hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames a),
              pure $ text $ isTypeInUniverse k])
-        (prettyErrorNoLoc showContext err)|]
+          (prettyErrorNoLoc err)|]
 
     WhileInferring ctx sg e err =>
       [|vappendBlank
@@ -363,7 +381,7 @@ prettyErrorNoLoc showContext = \case
             [hangDSingle "while inferring the type of"
                 !(prettyElim ctx.dnames ctx.tnames e),
              hangDSingle "with quantity" !(prettyQty sg.qty)])
-        (prettyErrorNoLoc showContext err)|]
+          (prettyErrorNoLoc err)|]
 
     WhileComparingT ctx mode sg a s t err =>
       [|vappendBlank
@@ -373,7 +391,7 @@ prettyErrorNoLoc showContext = \case
                 !(prettyTerm [<] ctx.tnames t),
              hangDSingle "at type" !(prettyTerm [<] ctx.tnames a),
              hangDSingle "with quantity" !(prettyQty sg.qty)])
-        (prettyErrorNoLoc showContext err)|]
+          (prettyErrorNoLoc err)|]
 
     WhileComparingE ctx mode sg e f err =>
       [|vappendBlank
@@ -382,26 +400,13 @@ prettyErrorNoLoc showContext = \case
              hangDSingle (text "is \{prettyMode mode}")
                 !(prettyElim [<] ctx.tnames f),
              hangDSingle "with quantity" !(prettyQty sg.qty)])
-        (prettyErrorNoLoc showContext err)|]
+          (prettyErrorNoLoc err)|]
 
   where
     vappendBlank : Doc opts -> Doc opts -> Doc opts
     vappendBlank a b = flush a `vappend` b
 
-  inTContext : TyContext d n -> Doc opts -> Eff Pretty (Doc opts)
-  inTContext ctx doc =
-    if showContext && not (null ctx) then
-      pure $ vappend doc (sep ["in context", !(prettyTyContext ctx)])
-    else pure doc
-
-  inEContext : EqContext n -> Doc opts -> Eff Pretty (Doc opts)
-  inEContext ctx doc =
-    if showContext && not (null ctx) then
-      pure $ vappend doc (sep ["in context", !(prettyEqContext ctx)])
-    else pure doc
-
   export
-prettyError : {opts : _} -> (showContext : Bool) ->
+  prettyError : Error -> Eff Pretty (Doc opts)
-              Error -> Eff Pretty (Doc opts)
+  prettyError err = sep <$> sequence
-prettyError showContext err = sep <$> sequence
+    [prettyLoc err.loc, indentD =<< prettyErrorNoLoc err]
-  [prettyLoc err.loc, indentD =<< prettyErrorNoLoc showContext err]