pretty printing errors

lib/Quox/Typing/Error.idr

@@ -19,7 +19,7 @@ data Error q
 | ExpectedEq   (TyContext q d n) (Term q d n)
 | BadUniverse  Universe Universe
 | TagNotIn     TagVal (SortedSet TagVal)
-| BadCaseQtys  (TyContext q d n) (List (QOutput q n, TagVal, Term q d n))
+| BadCaseQtys  (TyContext q d n) (List (QOutput q n, Term q d n, Term q d n))
 
 -- first term arg of ClashT is the type
 | ClashT  (EqContext q n) EqMode (Term q 0 n) (Term q 0 n) (Term q 0 n)
@@ -30,7 +30,7 @@ data Error q
 | NotInScope Name
 
 | NotType (TyContext q d n) (Term q d n)
-| WrongType (EqContext q n) (Term q 0 n) (Term q 0 n) (Term q 0 n)
+| WrongType (EqContext q n) (Term q 0 n) (Term q 0 n)
 
 -- extra context
 | WhileChecking
@@ -136,3 +136,167 @@ parameters {auto _ : HasErr q m}
   expectModeU : EqMode -> Universe -> Universe -> m ()
   expectModeU mode = expect (ClashU mode) $ ucmp mode
 
+
+private
+prettyMode : EqMode -> Doc HL
+prettyMode Equal = "equal to"
+prettyMode Sub   = "a subtype of"
+prettyMode Super = "a supertype of"
+
+private
+prettyModeU : EqMode -> Doc HL
+prettyModeU Equal = "equal to"
+prettyModeU Sub   = "less than or equal to"
+prettyModeU Super = "greater than or equal to"
+
+private
+isTypeInUniverse : Maybe Universe -> Doc HL
+isTypeInUniverse Nothing  = "is a type"
+isTypeInUniverse (Just k) = "is a type in universe" <++> prettyUniverse k
+
+parameters {auto _ : (Eq q, PrettyHL q)} (unicode : Bool)
+  private
+  termt : TyContext q d n -> Term q d n -> Doc HL
+  termt ctx = hang 4 . prettyTerm unicode ctx.dnames ctx.tnames
+
+  private
+  terme : EqContext q n -> Term q 0 n -> Doc HL
+  terme ctx = hang 4 . prettyTerm unicode [<] ctx.tnames
+
+  private
+  dissectCaseQtys : TyContext q d n ->
+                    NContext n' -> List (QOutput q n', Term q d n, z) ->
+                    List (Doc HL)
+  dissectCaseQtys ctx [<]        arms = []
+  dissectCaseQtys ctx (tel :< x) arms =
+    let qs = map (head . fst) arms
+        tl = dissectCaseQtys ctx tel (map (mapFst tail) arms)
+    in
+    if allSame qs then tl else
+    ("-" <++> asep [hsep [pretty0 unicode $ TV x, "is used with quantities"],
+                    hseparate comma $ map (pretty0 unicode) qs]) :: tl
+  where
+    allSame : List q -> Bool
+    allSame []        = True
+    allSame (q :: qs) = all (== q) qs
+
+  export
+  prettyWhnfError : WhnfError -> Doc HL
+  prettyWhnfError = \case
+    MissingEnumArm tag tags =>
+      sep [hsep ["the tag", hl Tag $ pretty tag, "is not contained in"],
+           termt empty $ Enum $ fromList tags]
+
+  -- [todo] only show some contexts, probably
+  export
+  prettyError : (showContext : Bool) -> Error q -> Doc HL
+  prettyError showContext = \case
+    ExpectedTYPE ctx s =>
+      sep ["expected a type universe, but got", termt ctx s]
+
+    ExpectedPi ctx s =>
+      sep ["expected a function type, but got", termt ctx s]
+
+    ExpectedSig ctx s =>
+      sep ["expected a pair type, but got", termt ctx s]
+
+    ExpectedEnum ctx s =>
+      sep ["expected an enumeration type, but got", termt ctx s]
+
+    ExpectedEq ctx s =>
+      sep ["expected an equality type, but got", termt ctx s]
+
+    BadUniverse k l =>
+      sep ["the universe level", prettyUniverse k,
+           "is not strictly less than", prettyUniverse l]
+
+    TagNotIn tag set =>
+      sep [sep ["tag", prettyTag tag, "is not contained in"],
+           termt empty (Enum set)]
+
+    BadCaseQtys ctx arms =>
+      hang 4 $ sep $
+        "inconsistent variable usage in case arms" ::
+        dissectCaseQtys ctx ctx.tnames arms
+
+    ClashT ctx mode ty s t =>
+      inEContext ctx $
+      sep ["the term", terme ctx s,
+           hsep ["is not", prettyMode mode], terme ctx t,
+           "at type", terme ctx ty]
+
+    ClashTy ctx mode a b =>
+      inEContext ctx $
+      sep ["the type", terme ctx a,
+           hsep ["is not", prettyMode mode], terme ctx b]
+
+    ClashE ctx mode e f =>
+      inEContext ctx $
+      sep ["the term", terme ctx $ E e,
+           hsep ["is not", prettyMode mode], terme ctx $ E f]
+
+    ClashU mode k l =>
+      sep ["the universe level", prettyUniverse k,
+           hsep ["is not", prettyMode mode], prettyUniverse l]
+
+    ClashQ pi rh =>
+      sep ["the quantity", pretty0 unicode pi,
+           "is not equal to", pretty0 unicode rh]
+
+    NotInScope x =>
+      hsep [hl' Free $ pretty0 unicode x, "is not in scope"]
+
+    NotType ctx s =>
+      inTContext ctx $
+      sep ["the term", termt ctx s, "is not a type"]
+
+    WrongType ctx ty s =>
+      inEContext ctx $
+      sep ["the term", terme ctx s,
+           "cannot have type", terme ctx ty]
+
+    WhileChecking ctx pi s a err =>
+      vsep [inTContext ctx $
+              sep ["while checking", termt ctx s,
+                   "has type", termt ctx a,
+                   hsep ["with quantity", pretty0 unicode pi]],
+            prettyError showContext err]
+
+    WhileCheckingTy ctx a k err =>
+      vsep [inTContext ctx $
+              sep ["while checking", termt ctx a,
+                   isTypeInUniverse k],
+            prettyError showContext err]
+
+    WhileInferring ctx pi e err =>
+      vsep [inTContext ctx $
+              sep ["while inferring the type of", termt ctx $ E e,
+                   hsep ["with quantity", pretty0 unicode pi]],
+            prettyError showContext err]
+
+    WhileComparingT ctx mode s t a err =>
+      vsep [inEContext ctx $
+              sep ["while checking that", terme ctx s,
+                   hsep ["is", prettyMode mode], terme ctx t,
+                   "at type", terme ctx a],
+            prettyError showContext err]
+
+    WhileComparingE ctx mode e f err =>
+      vsep [inEContext ctx $
+              sep ["while checking that", terme ctx $ E e,
+                   hsep ["is", prettyMode mode], terme ctx $ E f],
+            prettyError showContext err]
+
+    WhnfError err => prettyWhnfError err
+  where
+    inTContext : TyContext q d n -> Doc HL -> Doc HL
+    inTContext ctx doc =
+      if showContext then
+        vsep [sep ["in context", prettyTyContext unicode ctx], doc]
+      else doc
+
+    inEContext : EqContext q n -> Doc HL -> Doc HL
+    inEContext ctx doc =
+      if showContext then
+        vsep [sep ["in context", prettyEqContext unicode ctx], doc]
+      else doc