rewrite pretty printer

lib/Quox/Parser/FromParser.idr

@@ -6,6 +6,7 @@ import Quox.Parser.Parser
 import Quox.Typechecker
 
 import Data.List
+import Data.Maybe
 import Data.SnocVect
 import Quox.EffExtra
 

lib/Quox/Parser/FromParser/Error.idr

@@ -29,56 +29,73 @@ data Error =
   | WrapParseError String ParseError
 
 
-parameters (unicode, showContext : Bool)
-  export
-  prettyParseError1 : String -> ParsingError _ -> Doc HL
-  prettyParseError1 file (Error msg Nothing) =
-    pretty msg
-  prettyParseError1 file (Error msg (Just bounds)) =
-    hsep [prettyLoc $ makeLoc file bounds, pretty msg]
+export
+prettyLexError : {opts : _} -> String -> LexError -> Eff Pretty (Doc opts)
+prettyLexError file (Err reason line col char) = do
+  let loc = makeLoc file (MkBounds line col line col)
+  reason <- case reason of
+    EndInput    => pure "unexpected end of input"
+    NoRuleApply => pure $ text "unrecognised character: \{show char}"
+    ComposeNotClosing (sl, sc) (el, ec) => pure $
+      hsep ["unterminated token at", !(prettyBounds (MkBounds sl sc el ec))]
+  pure $ vappend !(prettyLoc loc) reason
 
-  export
-  prettyParseError : String -> ParseError -> Doc HL
-  prettyParseError file (LexError   err) =
-    vsep ["lexical error:", nest 2 $ pretty $ show err]
-  prettyParseError file (ParseError errs) =
-    vsep $ "parse error:" ::
-           map (("-" <++>) . prettyParseError1 file) (toList errs)
+export
+prettyParseError1 : {opts : _} -> String -> ParsingError _ ->
+                    Eff Pretty (Doc opts)
+prettyParseError1 file (Error msg Nothing) =
+  pure $ text msg
+prettyParseError1 file (Error msg (Just bounds)) =
+  pure $ vappend !(prettyLoc $ makeLoc file bounds) (text msg)
 
+export
+prettyParseError : {opts : _} -> String -> ParseError ->
+                   Eff Pretty (Doc opts)
+prettyParseError file (LexError err) =
+  pure $ vsep ["lexical error:", !(prettyLexError file err)]
+prettyParseError file (ParseError errs) =
+  map (vsep . ("parse error:" ::)) $
+    traverse (map ("-" <++>) . prettyParseError1 file) (toList errs)
+
+
+parameters (showContext : Bool)
   export
-  prettyError : Error -> Doc HL
+  prettyError : {opts : _} -> Error -> Eff Pretty (Doc opts)
   prettyError (AnnotationNeeded loc ctx tm) =
-    sep [prettyLoc loc <++> "the term",
-         prettyTerm unicode ctx.dnames ctx.tnames tm,
-         "needs a type annotation"]
+    [|vappend (prettyLoc loc)
+        (hangD "type annotation needed on"
+               !(prettyTerm ctx.dnames ctx.tnames tm))|]
     -- [todo] print the original PTerm instead
 
   prettyError (DuplicatesInEnum loc tags) =
-    sep [prettyLoc loc <++> "duplicate tags in enum type",
-         braces $ fillSep $ map pretty tags]
+    [|vappend (prettyLoc loc)
+        (hangD "duplicate tags in enum type" !(prettyEnum tags))|]
 
   prettyError (DimNotInScope loc i) =
-    sep [prettyLoc loc <++> "dimension",
-         pretty0 unicode $ DV $ fromString i, "not in scope"]
+    [|vappend (prettyLoc loc)
+        (pure $ hsep ["dimension", !(hl DVar $ text i), "not in scope"])|]
 
   prettyError (TermNotInScope loc x) =
-    sep [prettyLoc loc <++> "term variable",
-         hl Free $ pretty0 unicode x, "not in scope"]
+    [|vappend (prettyLoc loc)
+        (pure $ hsep ["term variable", !(prettyFree x), "not in scope"])|]
 
-  prettyError (QtyNotGlobal loc pi) =
-    sep [prettyLoc loc <++> "quantity", pretty0 unicode pi,
-         "can't be used on a top level declaration"]
+  prettyError (QtyNotGlobal loc pi) = pure $
+    vappend !(prettyLoc loc)
+      (sep ["quantity" <++> !(prettyQty pi),
+            "can't be used on a top level declaration"])
 
-  prettyError (DimNameInTerm loc i) =
-    sep [prettyLoc loc <++> "dimension variable",
-         pretty0 unicode $ DV $ fromString i, "used in a term context"]
+  prettyError (DimNameInTerm loc i) = pure $
+    vappend !(prettyLoc loc)
+      (sep ["dimension" <++> !(hl DVar $ text i),
+            "used in a term context"])
 
   prettyError (WrapTypeError err) =
-    Typing.prettyError unicode showContext $ trimContext 2 err
+    Typing.prettyError showContext $ trimContext 2 err
 
-  prettyError (LoadError loc str err) =
-    vsep [hsep [prettyLoc loc, "couldn't load file", pretty str],
-          fromString $ show err]
+  prettyError (LoadError loc str err) = pure $
+    vsep [!(prettyLoc loc),
+          "couldn't load file" <++> text str,
+          text $ show err]
 
   prettyError (WrapParseError file err) =
     prettyParseError file err