Merge pull request #21 from expipiplus1/doc-message

Add functionality to render diagnostics with user provided Docs

README.md

@@ -102,8 +102,8 @@ let beautifulExample =
 let diagnostic  = addFile def "somefile.zc" "let id<a>(x : a) : a := x\n  + 1"
 let diagnostic' = addReport diagnostic beautifulExample
 
--- Print with unicode characters, colors and the default style
+-- Print with unicode characters, and the default (colorful) style
-printDiagnostic stdout True True 4 defaultStyle diagnostic'
+printDiagnostic stdout WithUnicode 4 defaultStyle diagnostic'
 ```
 
 More examples are given in the [`test/rendering`](./test/rendering) folder (execute `stack test` to see the output).

diagnose.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           diagnose
-version:        2.4.0
+version:        2.5.0
 synopsis:       Beautiful error reporting done easily
 description:    This package provides a simple way of getting beautiful compiler/interpreter errors
                 using a very simple interface for the programmer.

src/Error/Diagnose.hs

@@ -241,7 +241,7 @@ import Error.Diagnose.Style as Export
 --   >            --   Creates a new diagnostic with no default hints from the bundle returned by megaparsec
 --   >         diag' = addFile diag filename content
 --   >            --   Add the file used when parsing with the same filename given to 'MP.runParser'
---   >     in printDiagnostic stderr True True 4 diag'
+--   >     in printDiagnostic stderr True 4 diag'
 --   >   Right res   -> print res
 --
 --   This example will return the following error message (assuming default instances for @'Error.Diagnose.Compat.Megaparsec.HasHints' 'Data.Void.Void' msg@):
@@ -282,7 +282,7 @@ import Error.Diagnose.Style as Export
 --   >            --   Creates a new diagnostic with no default hints from the bundle returned by megaparsec
 --   >         diag' = addFile diag filename content
 --   >            --   Add the file used when parsing with the same filename given to 'MP.runParser'
---   >     in printDiagnostic stderr True True 4 diag'
+--   >     in printDiagnostic stderr True 4 diag'
 --   >   Right res  -> print res
 --
 --   This will output the following error on @stderr@:

src/Error/Diagnose/Diagnostic.hs

@@ -25,7 +25,11 @@ import Error.Diagnose.Diagnostic.Internal as Export
     hasReports,
     reportsOf,
     prettyDiagnostic,
+    prettyDiagnostic',
     printDiagnostic,
+    printDiagnostic',
     warningsToErrors,
+    WithUnicode(..),
+    TabSize(..),
   )
 import System.IO as Export (stderr, stdout)

src/Error/Diagnose/Diagnostic/Internal.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE FlexibleInstances #-}
 
 -- |
@@ -13,7 +14,7 @@
 --            It is also highly undocumented.
 --
 --            Please limit yourself to the "Error.Diagnose.Diagnostic" module, which exports some of the useful functions defined here.
-module Error.Diagnose.Diagnostic.Internal (module Error.Diagnose.Diagnostic.Internal, def) where
+module Error.Diagnose.Diagnostic.Internal (module Error.Diagnose.Diagnostic.Internal, def, WithUnicode(..), TabSize(..)) where
 
 import Control.Monad.IO.Class (MonadIO, liftIO)
 #ifdef USE_AESON
@@ -29,10 +30,10 @@ import Data.Foldable (fold, toList)
 import qualified Data.HashMap.Lazy as HashMap
 import Data.List (intersperse)
 import Error.Diagnose.Report (Report)
-import Error.Diagnose.Report.Internal (FileMap, errorToWarning, prettyReport, warningToError)
+import Error.Diagnose.Report.Internal (FileMap, errorToWarning, prettyReport, warningToError, WithUnicode(..), TabSize(..))
 import Error.Diagnose.Style (Annotation, Style)
-import Prettyprinter (Doc, Pretty, hardline, unAnnotate)
+import Prettyprinter (Doc, Pretty, hardline, pretty, defaultLayoutOptions, reAnnotateS, layoutPretty)
-import Prettyprinter.Render.Terminal (hPutDoc)
+import Prettyprinter.Render.Terminal (renderIO)
 import System.IO (Handle)
 
 -- | The data type for diagnostic containing messages of an abstract type.
@@ -47,6 +48,7 @@ data Diagnostic msg
       --   Reports are output one by one, without connections in between.
       !FileMap
       -- ^ A map associating files with their content as lists of lines.
+  deriving (Functor, Foldable, Traversable)
 
 instance Default (Diagnostic msg) where
   def = Diagnostic mempty mempty
@@ -98,36 +100,70 @@ errorsToWarnings (Diagnostic reports files) = Diagnostic (errorToWarning <$> rep
 prettyDiagnostic ::
   Pretty msg =>
   -- | Should we use unicode when printing paths?
-  Bool ->
+  WithUnicode ->
   -- | The number of spaces each TAB character will span.
-  Int ->
+  TabSize ->
   -- | The diagnostic to print.
   Diagnostic msg ->
-  Doc Annotation
+  Doc (Annotation ann)
-prettyDiagnostic withUnicode tabSize (Diagnostic reports file) =
+prettyDiagnostic withUnicode tabSize =
-  fold . intersperse hardline $ prettyReport file withUnicode tabSize <$> toList reports
+  prettyDiagnostic' withUnicode tabSize . fmap pretty
 {-# INLINE prettyDiagnostic #-}
 
+-- | Like 'prettyDiagnostic' except that instead of requiring a 'pretty'
+-- instance for messages, this allows passing in your own 'Doc'. Custom
+-- annotations are retained in 'OtherStyle'
+prettyDiagnostic' ::
+  -- | Should we use unicode when printing paths?
+  WithUnicode ->
+  -- | The number of spaces each TAB character will span.
+  TabSize ->
+  -- | The diagnostic to print.
+  Diagnostic (Doc ann) ->
+  Doc (Annotation ann)
+prettyDiagnostic' withUnicode tabSize (Diagnostic reports file) =
+  fold . intersperse hardline $ prettyReport file withUnicode tabSize <$> toList reports
+
 -- | Prints a 'Diagnostic' onto a specific 'Handle'.
 printDiagnostic ::
   (MonadIO m, Pretty msg) =>
   -- | The handle onto which to output the diagnostic.
   Handle ->
   -- | Should we print with unicode characters?
-  Bool ->
+  WithUnicode ->
-  -- | 'False' to disable colors.
-  Bool ->
   -- | The number of spaces each TAB character will span.
-  Int ->
+  TabSize ->
   -- | The style in which to output the diagnostic.
-  Style ->
+  Style ann ->
   -- | The diagnostic to output.
   Diagnostic msg ->
   m ()
-printDiagnostic handle withUnicode withColors tabSize style diag =
+printDiagnostic handle withUnicode tabSize style =
-  liftIO $ hPutDoc handle ((if withColors then style else unAnnotate) $ prettyDiagnostic withUnicode tabSize diag)
+  printDiagnostic' handle withUnicode tabSize style . fmap pretty
 {-# INLINE printDiagnostic #-}
 
+-- | Like 'printDiagnostic' except that instead of requiring a 'pretty'
+-- instance for messages, this allows passing in your own 'Doc'.
+printDiagnostic' ::
+  MonadIO m =>
+  -- | The handle onto which to output the diagnostic.
+  Handle ->
+  -- | Should we print with unicode characters?
+  WithUnicode ->
+  -- | The number of spaces each TAB character will span.
+  TabSize ->
+  -- | The style in which to output the diagnostic.
+  Style ann ->
+  -- | The diagnostic to output.
+  Diagnostic (Doc ann) ->
+  m ()
+printDiagnostic' handle withUnicode tabSize style =
+  liftIO
+    . renderIO handle
+    . reAnnotateS style
+    . layoutPretty defaultLayoutOptions
+    . prettyDiagnostic' withUnicode tabSize
+
 -- | Inserts a new referenceable file within the diagnostic.
 addFile ::
   Diagnostic msg ->

src/Error/Diagnose/Pretty.hs

@@ -1,4 +1,3 @@
 module Error.Diagnose.Pretty (module Export) where
 
 import qualified Prettyprinter as Export 
-import qualified Prettyprinter.Render.Terminal as Export 

src/Error/Diagnose/Report/Internal.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -23,6 +24,8 @@
 module Error.Diagnose.Report.Internal
   ( module Error.Diagnose.Report.Internal
   , Report(.., Warn, Err)
+  , WithUnicode(..)
+  , TabSize(..)
   ) where
 
 #ifdef USE_AESON
@@ -47,8 +50,9 @@ import Data.String (IsString (fromString))
 import qualified Data.Text as Text
 import Error.Diagnose.Position
 import Error.Diagnose.Style (Annotation (..))
-import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>))
+import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>), reAnnotate, SimpleDocStream (..), layoutCompact)
-import Prettyprinter.Internal (Doc (..))
+import Prettyprinter.Internal (Doc (..), textSpaces)
+import Data.Bool (bool)
 
 type FileMap = HashMap FilePath (Array Int String)
 
@@ -67,6 +71,7 @@ data Report msg
       -- ^ A map associating positions with marker to show under the source code.
       [Note msg]
       -- ^ A list of notes to add at the end of the report.
+  deriving (Functor, Foldable, Traversable)
 
 -- | Pattern synonym for a warning report.
 pattern Warn :: Maybe msg -> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
@@ -120,6 +125,7 @@ data Marker msg
     Maybe msg
   | -- | An empty marker, whose sole purpose is to include a line of code in the report without markers under.
     Blank
+  deriving (Functor, Foldable, Traversable)
 
 instance Eq (Marker msg) where
   This _ == This _ = True
@@ -147,6 +153,7 @@ data Note msg
     Note msg
   | -- | A hint, to propose potential fixes or help towards fixing the issue.
     Hint msg
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
 
 #ifdef USE_AESON
 instance ToJSON msg => ToJSON (Note msg) where
@@ -187,18 +194,21 @@ errorToWarning :: Report msg -> Report msg
 errorToWarning (Report True code msg markers notes) = Report False code msg markers notes
 errorToWarning r@(Report False _ _ _ _) = r
 
+data WithUnicode = WithoutUnicode | WithUnicode
+
+newtype TabSize = TabSize Int
+
 -- | Pretty prints a report to a 'Doc' handling colors.
 prettyReport ::
-  Pretty msg =>
   -- | The content of the file the reports are for
   FileMap ->
   -- | Should we print paths in unicode?
-  Bool ->
+  WithUnicode ->
   -- | The number of spaces each TAB character will span
-  Int ->
+  TabSize ->
   -- | The whole report to output
-  Report msg ->
+  Report (Doc ann) ->
-  Doc Annotation
+  Doc (Annotation ann)
 prettyReport fileContent withUnicode tabSize (Report isError code message markers hints) =
   let sortedMarkers = List.sortOn (fst . begin . fst) markers
       -- sort the markers so that the first lines of the reports are the first lines of the file
@@ -219,7 +229,7 @@ prettyReport fileContent withUnicode tabSize (Report isError code message marker
                  )
               <> case code of
                 Nothing -> rbracket
-                Just code -> space <> pretty code <> rbracket
+                Just code -> space <> annotated code <> rbracket
           )
    in {-
               A report is of the form:
@@ -234,7 +244,7 @@ prettyReport fileContent withUnicode tabSize (Report isError code message marker
               (6)    -------+
       -}
 
-      {- (1) -} header <> colon <+> align (pretty message)
+      {- (1) -} header <> colon <+> align (annotated message)
         <> {- (2), (3), (4) -} fold (uncurry (prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength) <$> groupedMarkers)
         <> {- (5) -} ( if
                            | null hints && null markers -> mempty
@@ -246,7 +256,7 @@ prettyReport fileContent withUnicode tabSize (Report isError code message marker
         <> {- (6) -} ( if null markers && null hints
                          then mempty
                          else
-                           annotate RuleColor (pad (maxLineNumberLength + 2) (if withUnicode then '─' else '-') mempty <> if withUnicode then "╯" else "+")
+                           annotate RuleColor (pad (maxLineNumberLength + 2) (unicode '-' '─' withUnicode) mempty <> unicode "+" "╯" withUnicode)
                              <> hardline
                      )
 
@@ -268,9 +278,11 @@ dotPrefix ::
   -- | The length of the left space before the bullet.
   Int ->
   -- | Whether to print with unicode characters or not.
-  Bool ->
+  WithUnicode ->
-  Doc Annotation
+  Doc (Annotation ann)
-dotPrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (if withUnicode then "•" else ":")
+dotPrefix leftLen withUnicode =
+  pad leftLen ' ' mempty
+    <+> annotate RuleColor (unicode ":" "•" withUnicode)
 {-# INLINE dotPrefix #-}
 
 -- | Creates a "pipe"-prefix for a report line where there is no code.
@@ -283,9 +295,9 @@ pipePrefix ::
   -- | The length of the left space before the pipe.
   Int ->
   -- | Whether to print with unicode characters or not.
-  Bool ->
+  WithUnicode ->
-  Doc Annotation
+  Doc (Annotation ann)
-pipePrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (if withUnicode then "│" else "|")
+pipePrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (unicode "|" "│" withUnicode)
 {-# INLINE pipePrefix #-}
 
 -- | Creates a line-prefix for a report line containing source code
@@ -302,11 +314,11 @@ linePrefix ::
   -- | The line number to show.
   Int ->
   -- | Whether to use unicode characters or not.
-  Bool ->
+  WithUnicode ->
-  Doc Annotation
+  Doc (Annotation ann)
 linePrefix leftLen lineNo withUnicode =
   let lineNoLen = length (show lineNo)
-   in annotate RuleColor $ mempty <+> pad (leftLen - lineNoLen) ' ' mempty <> pretty lineNo <+> if withUnicode then "│" else "|"
+   in annotate RuleColor $ mempty <+> pad (leftLen - lineNoLen) ' ' mempty <> pretty lineNo <+> unicode "|" "│" withUnicode
 {-# INLINE linePrefix #-}
 
 -- | Creates an ellipsis-prefix, when some line numbers are not consecutive.
@@ -317,12 +329,11 @@ linePrefix leftLen lineNo withUnicode =
 --   [without unicode] "@␣␣␣␣...@"
 ellipsisPrefix ::
   Int ->
-  Bool ->
+  WithUnicode ->
-  Doc Annotation
+  Doc (Annotation ann)
-ellipsisPrefix leftLen withUnicode = pad leftLen ' ' mempty <> annotate RuleColor (if withUnicode then space <> "⋮" else "...")
+ellipsisPrefix leftLen withUnicode = pad leftLen ' ' mempty <> annotate RuleColor (unicode "..." (space <> "⋮") withUnicode)
 
 groupMarkersPerFile ::
-  Pretty msg =>
   [(Position, Marker msg)] ->
   [(Bool, [(Position, Marker msg)])]
 groupMarkersPerFile [] = []
@@ -346,22 +357,21 @@ groupMarkersPerFile markers =
 
 -- | Prettyprint a sub-report, which is a part of the report spanning across a single file
 prettySubReport ::
-  Pretty msg =>
   -- | The content of files in the diagnostics
   FileMap ->
   -- | Is the output done with Unicode characters?
-  Bool ->
+  WithUnicode ->
   -- | Is the current report an error report?
   Bool ->
   -- | The number of spaces each TAB character will span
-  Int ->
+  TabSize ->
   -- | The size of the biggest line number
   Int ->
   -- | Is this sub-report the first one in the list?
   Bool ->
   -- | The list of line-ordered markers appearing in a single file
-  [(Position, Marker msg)] ->
+  [(Position, Marker (Doc ann))] ->
-  Doc Annotation
+  Doc (Annotation ann)
 prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength isFirst markers =
   let (markersPerLine, multilineMarkers) = splitMarkersPerLine markers
       -- split the list on whether markers are multiline or not
@@ -377,16 +387,16 @@ prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength isFi
         ( if isFirst
             then
               space <> pad maxLineNumberLength ' ' mempty
-                <+> annotate RuleColor (if withUnicode then "╭──▶" else "+-->")
+                <+> annotate RuleColor (unicode "+-->" "╭──▶" withUnicode)
             else
               space <> dotPrefix maxLineNumberLength withUnicode <> hardline
-                <> annotate RuleColor (pad (maxLineNumberLength + 2) (if withUnicode then '─' else '-') mempty)
+                <> annotate RuleColor (pad (maxLineNumberLength + 2) (unicode '-' '─' withUnicode) mempty)
-                <> annotate RuleColor (if withUnicode then "┼──▶" else "+-->")
+                <> annotate RuleColor (unicode "+-->" "┼──▶" withUnicode)
         )
           <+> annotate FileColor reportFile
    in {- (2) -} hardline <> fileMarker
         <> hardline
-          <+> {- (3) -} pipePrefix maxLineNumberLength withUnicode
+          <+> {- (3) -}  {- (3) -} pipePrefix maxLineNumberLength withUnicode
         <> {- (4) -} prettyAllLines fileContent withUnicode isError tabSize maxLineNumberLength sortedMarkersPerLine multilineMarkers allLineNumbers
 
 isThisMarker :: Marker msg -> Bool
@@ -404,17 +414,16 @@ splitMarkersPerLine (m@(Position {..}, _) : ms) =
 
 -- |
 prettyAllLines ::
-  Pretty msg =>
   FileMap ->
-  Bool ->
+  WithUnicode ->
   Bool ->
   -- | The number of spaces each TAB character will span
+  TabSize ->
   Int ->
-  Int ->
+  [(Int, [(Position, Marker (Doc ann))])] ->
-  [(Int, [(Position, Marker msg)])] ->
+  [(Position, Marker (Doc ann))] ->
-  [(Position, Marker msg)] ->
   [Int] ->
-  Doc Annotation
+  Doc (Annotation ann)
 prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNumbers =
   case lineNumbers of
     [] ->
@@ -456,19 +465,14 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu
               if not $ null multiline
                 then
                   if not $ null allMultilineMarkersSpanningLine
-                    then colorOfFirstMultilineMarker if withUnicode then "│  " else "|  "
+                    then colorOfFirstMultilineMarker (unicode "|  " "│  " withUnicode)
                     else "   "
                 else mempty
             (p@(Position _ (el, _) _), marker) : _ ->
               let hasPredecessor = el == line || maybe False ((/=) p . fst . fst) (List.safeUncons multiline)
                in colorOfFirstMultilineMarker
-                    ( if
+                    (unicode (bool "+" "|" hasPredecessor ) (bool "╭" "├" hasPredecessor) withUnicode)
-                          | hasPredecessor && withUnicode -> "├"
+                    <> annotate (markerColor isError marker) (unicode ">" "┤" withUnicode)
-                          | hasPredecessor -> "|"
-                          | withUnicode -> "╭"
-                          | otherwise -> "+"
-                    )
-                    <> annotate (markerColor isError marker) (if withUnicode then "┤" else ">")
                     <> space
 
           -- we need to remove all blank markers because they are irrelevant to the display
@@ -478,7 +482,7 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu
           (widths, renderedCode) = getLine_ files (allInlineMarkersInLine <> allMultilineMarkersInLine <> allMultilineMarkersSpanningLine') line tabSize isError
        in ( otherMultilines,
             hardline
-              <> {- (1) -} linePrefix leftLen line withUnicode <+> additionalPrefix
+              <> {- (1) -} linePrefix leftLen line withUnicode <+>  additionalPrefix
               <> renderedCode
               <> {- (2) -} showAllMarkersInLine (not $ null multiline) inSpanOfMultiline colorOfFirstMultilineMarker withUnicode isError leftLen widths allInlineMarkersInLine'
               <> showMultiline (isLastLine || List.safeLast multilineEndingOnLine == List.safeLast multiline) multilineEndingOnLine
@@ -489,33 +493,33 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu
       let colorOfFirstMultilineMarker = markerColor isError . snd <$> List.safeHead multiline
           -- take the color of the last multiline marker in case we need to add additional bars
 
-          prefix = hardline <+> dotPrefix leftLen withUnicode <> space
+          prefix = space <> dotPrefix leftLen withUnicode <> space
 
-          prefixWithBar color = prefix <> maybe id annotate color (if withUnicode then "│ " else "| ")
+          prefixWithBar color = prefix <> maybe id annotate color (unicode "| " "│ " withUnicode)
 
           showMultilineMarkerMessage (_, Blank) _ = mempty
           showMultilineMarkerMessage (_, marker) isLast =
             annotate (markerColor isError marker) $
               ( if isLast && isLastMultiline
-                  then if withUnicode then "╰╸ " else "`- "
+                  then unicode "`- " "╰╸ " withUnicode
-                  else if withUnicode then "├╸ " else "|- "
+                  else unicode "|- " "├╸ " withUnicode
               )
-                <> replaceLinesWith (if isLast then prefix <> "   " else prefixWithBar (Just $ markerColor isError marker) <> space) (pretty $ markerMessage marker)
+                <> replaceLinesWith (if isLast then prefix <> "   " else prefixWithBar (Just $ markerColor isError marker) <> space) 0 (annotated $ markerMessage marker)
 
           showMultilineMarkerMessages [] = []
           showMultilineMarkerMessages [m] = [showMultilineMarkerMessage m True]
           showMultilineMarkerMessages (m : ms) = showMultilineMarkerMessage m False : showMultilineMarkerMessages ms
-       in prefixWithBar colorOfFirstMultilineMarker <> prefix <> fold (List.intersperse prefix $ showMultilineMarkerMessages multiline)
+       in hardline <> prefixWithBar colorOfFirstMultilineMarker <> hardline <> prefix <> fold (List.intersperse (hardline <> prefix) $ showMultilineMarkerMessages multiline)
 
 -- |
 getLine_ ::
   FileMap ->
   [(Position, Marker msg)] ->
   Int ->
-  Int ->
+  TabSize ->
   Bool ->
-  (WidthTable, Doc Annotation)
+  (WidthTable, Doc (Annotation ann))
-getLine_ files markers line tabSize isError =
+getLine_ files markers line (TabSize tabSize) isError =
   case safeArrayIndex (line - 1) =<< (HashMap.!?) files . file . fst =<< List.safeHead markers of
     Nothing ->
       ( mkWidthTable "",
@@ -548,12 +552,12 @@ getLine_ files markers line tabSize isError =
     mkWidthTable s = listArray (1, length s) (ifTab tabSize wcwidth <$> s)
 
 -- |
-showAllMarkersInLine :: Pretty msg => Bool -> Bool -> (Doc Annotation -> Doc Annotation) -> Bool -> Bool -> Int -> WidthTable -> [(Position, Marker msg)] -> Doc Annotation
+showAllMarkersInLine :: Bool -> Bool -> (Doc (Annotation ann) -> Doc (Annotation ann)) -> WithUnicode -> Bool -> Int -> WidthTable -> [(Position, Marker (Doc ann))] -> Doc (Annotation ann)
 showAllMarkersInLine _ _ _ _ _ _ _ [] = mempty
 showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUnicode isError leftLen widths ms =
   let maxMarkerColumn = snd $ end $ fst $ List.last $ List.sortOn (snd . end . fst) ms
       specialPrefix
-        | inSpanOfMultiline = colorMultilinePrefix (if withUnicode then "│ " else "| ") <> space
+        | inSpanOfMultiline = colorMultilinePrefix (unicode "| " "│ " withUnicode) <> space
         | hasMultilines = colorMultilinePrefix "  " <> space
         | otherwise = mempty
    in -- get the maximum end column, so that we know when to stop looking for other markers on the same line
@@ -574,8 +578,8 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn
                 annotate
                   (markerColor isError marker)
                   ( if snd begin == n
-                      then (if withUnicode then "┬" else "^") <> fold (replicate (widthAt n - 1) if withUnicode then "─" else "-")
+                      then unicode "^" "┬" withUnicode <> fold (replicate (widthAt n - 1) (unicode "-" "─" withUnicode))
-                      else fold (replicate (widthAt n) if withUnicode then "─" else "-")
+                      else fold (replicate (widthAt n) (unicode "-" "─" withUnicode))
                   )
                   <> showMarkers (n + 1) lineLen
 
@@ -606,7 +610,7 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn
               let (pipesBefore, pipesAfter) = List.partition ((< bc) . snd . begin . fst) nubbedPipes
                   -- split the list so that all pipes before can have `|`s but pipes after won't
 
-                  pipesBeforeRendered = pipesBefore <&> second \marker -> annotate (markerColor isError marker) (if withUnicode then "│" else "|")
+                  pipesBeforeRendered = pipesBefore <&> second \marker -> annotate (markerColor isError marker) (unicode "|" "│" withUnicode)
                   -- pre-render pipes which are before because they will be shown
 
                   lastBeginPosition = snd . begin . fst <$> List.safeLast (List.sortOn (snd . begin . fst) pipesAfter)
@@ -615,49 +619,56 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn
                     Nothing -> 0
                     Just col -> widthsBetween bc col
 
-                  currentPipe =
+                  currentPipe = unicode (bool "`" "|" hasSuccessor) (bool "╰" "├" hasSuccessor) withUnicode
-                    if
-                        | withUnicode && hasSuccessor -> "├"
-                        | withUnicode -> "╰"
-                        | hasSuccessor -> "|"
-                        | otherwise -> "`"
 
-                  lineChar = if withUnicode then '─' else '-'
+                  lineChar = unicode '-' '─' withUnicode
-                  pointChar = if withUnicode then "╸" else "-"
+                  pointChar = unicode "-" "╸" withUnicode
 
                   bc' = bc + lineLen + 2
                   pipesBeforeMessageStart = List.filter ((< bc') . snd . begin . fst) pipesAfter
                   -- consider pipes before, as well as pipes which came before the text rectangle bounds
-                  pipesBeforeMessageRendered = (pipesBefore <> pipesBeforeMessageStart) <&> second \marker -> annotate (markerColor isError marker) (if withUnicode then "│" else "|")
+                  pipesBeforeMessageRendered = (pipesBefore <> pipesBeforeMessageStart) <&> second \marker -> annotate (markerColor isError marker) (unicode "|" "│" withUnicode)
                in -- also pre-render pipes which are before the message text bounds, because they will be shown if the message is on
                   -- multiple lines
 
                   lineStart pipesBeforeRendered
                     <> annotate (markerColor isError msg) (currentPipe <> pretty (replicate lineLen lineChar) <> pointChar)
-                    <+> annotate (markerColor isError msg) (replaceLinesWith (hardline <+> lineStart pipesBeforeMessageRendered <+> if List.null pipesBeforeMessageStart then "  " else " ") $ pretty $ markerMessage msg)
+                    <+> annotate (markerColor isError msg) (replaceLinesWith (space <> lineStart pipesBeforeMessageRendered <+> if List.null pipesBeforeMessageStart then "  " else " ") 0 $ annotated $ markerMessage msg)
          in hardline <+> prefix <> showMessages specialPrefix pipes lineLen
 
 -- WARN: uses the internal of the library
 --
 --       DO NOT use a wildcard here, in case the internal API exposes one more constructor
-
+replaceLinesWith :: Doc ann -> Int -> Doc ann -> Doc ann
--- |
+replaceLinesWith repl = go
-replaceLinesWith :: Doc ann -> Doc ann -> Doc ann
+ where
-replaceLinesWith repl Line = repl
+  replWidth = sdsWidth . layoutCompact $ repl
-replaceLinesWith _ Fail = Fail
+  sdsWidth = \case
-replaceLinesWith _ Empty = Empty
+    SFail -> 0
-replaceLinesWith _ (Char c) = Char c
+    SEmpty -> 0
-replaceLinesWith repl (Text _ s) =
+    SChar _ sds -> 1 + sdsWidth sds
-  let lines = Text.split (== '\n') s <&> \txt -> Text (Text.length txt) txt
+    SText l _ sds -> l + sdsWidth sds
-   in mconcat (List.intersperse repl lines)
+    SLine _ _ -> error "replaceLinesWith was given a prefix with a line break"
-replaceLinesWith repl (FlatAlt f d) = FlatAlt (replaceLinesWith repl f) (replaceLinesWith repl d)
+    SAnnPush _ sds -> sdsWidth sds
-replaceLinesWith repl (Cat c d) = Cat (replaceLinesWith repl c) (replaceLinesWith repl d)
+    SAnnPop sds -> sdsWidth sds
-replaceLinesWith repl (Nest n d) = Nest n (replaceLinesWith repl d)
+  replWithNesting n = hardline <> repl <> pretty (textSpaces n)
-replaceLinesWith repl (Union c d) = Union (replaceLinesWith repl c) (replaceLinesWith repl d)
+  go n = \case
-replaceLinesWith repl (Column f) = Column (replaceLinesWith repl . f)
+    Line -> replWithNesting n
-replaceLinesWith repl (Nesting f) = Nesting (replaceLinesWith repl . f)
+    Fail -> Fail
-replaceLinesWith repl (Annotated ann doc) = Annotated ann (replaceLinesWith repl doc)
+    Empty -> Empty
-replaceLinesWith repl (WithPageWidth f) = WithPageWidth (replaceLinesWith repl . f)
+    Char c -> Char c
+    Text l txt -> Text l txt
+    FlatAlt f d -> FlatAlt (go n f) (go n d)
+    Cat c d -> Cat (go n c) (go n d)
+    Nest n' d -> go (n + n') d
+    Union c d -> Union (go n c) (go n d)
+    Column f -> Column (go n . f)
+    -- In this case we add both our fake nesting level (from the 'Nest'
+    -- constructors we've eliminated) and the nesting level from the line
+    -- prefixes
+    Nesting f -> Nesting (go n . f . (+ replWidth) . (+ n))
+    Annotated ann doc -> Annotated ann (go n doc)
+    WithPageWidth f -> WithPageWidth (go n . f)
 
 -- | Extracts the color of a marker as a 'Doc' coloring function.
 markerColor ::
@@ -667,7 +678,7 @@ markerColor ::
   -- | The marker to extract the color from.
   Marker msg ->
   -- | A function used to color a 'Doc'.
-  Annotation
+  Annotation ann
 markerColor isError (This _) = ThisColor isError
 markerColor _ (Where _) = WhereColor
 markerColor _ (Maybe _) = MaybeColor
@@ -683,15 +694,15 @@ markerMessage Blank = undefined
 {-# INLINE markerMessage #-}
 
 -- | Pretty prints all hints.
-prettyAllHints :: Pretty msg => [Note msg] -> Int -> Bool -> Doc Annotation
+prettyAllHints :: [Note (Doc ann)] -> Int -> WithUnicode -> Doc (Annotation ann)
 prettyAllHints [] _ _ = mempty
 prettyAllHints (h : hs) leftLen withUnicode =
   {-
         A hint is composed of:
         (1)         : Hint: <hint message>
   -}
-  let prefix = hardline <+> pipePrefix leftLen withUnicode
+  let prefix = space <> pipePrefix leftLen withUnicode
-   in prefix <+> annotate HintColor (notePrefix h <+> replaceLinesWith (prefix <+> "      ") (pretty $ noteMessage h))
+   in hardline <> prefix <+> annotate HintColor (notePrefix h <+> replaceLinesWith prefix 7 (annotated $ noteMessage h))
         <> prettyAllHints hs leftLen withUnicode
   where
     notePrefix (Note _) = "Note:"
@@ -704,3 +715,11 @@ safeArrayIndex :: (Ix i, IArray a e) => i -> a i e -> Maybe e
 safeArrayIndex i a
   | Array.inRange (Array.bounds a) i = Just (a ! i)
   | otherwise = Nothing
+
+annotated :: Doc ann -> Doc (Annotation ann)
+annotated = reAnnotate OtherStyle
+
+unicode :: a -> a -> WithUnicode -> a
+unicode f t = \case
+  WithoutUnicode -> f
+  WithUnicode -> t

src/Error/Diagnose/Style.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE DeriveTraversable #-}
+
 -- |
 -- Module      : Error.Diagnose.Style
 -- Description : Custom style definitions
@@ -11,15 +13,12 @@ module Error.Diagnose.Style
     Style,
     -- $defining_new_styles
 
-    -- * Default style specification
+    -- * Styles
     defaultStyle,
-
+    unadornedStyle,
-    -- * Re-exports
-    reAnnotate,
   )
 where
 
-import Prettyprinter (Doc, reAnnotate)
 import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), bold, color, colorDull)
 
 -- $defining_new_styles
@@ -41,7 +40,7 @@ import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), bold, color, colorD
 -- For simplicity's sake, a default style is given as 'defaultStyle'.
 
 -- | Some annotations as placeholders for colors in a 'Doc'.
-data Annotation
+data Annotation a
   = -- | The color of 'Error.Diagnose.Report.This' markers, depending on whether the report is an error
     --   report or a warning report.
     ThisColor
@@ -67,18 +66,25 @@ data Annotation
   | -- | Additional style to apply to marker rules (e.g. bold) on top of some
     --   already processed color annotation.
     MarkerStyle
-      Annotation
+      (Annotation a)
   | -- | The color of the code when no marker is present.
     CodeStyle
+  | -- | Something else, could be provided by the user
+    OtherStyle a
+  deriving (Functor, Foldable, Traversable)
 
 -- | A style is a function which can be applied using 'reAnnotate'.
 --
 --   It transforms a 'Doc'ument containing 'Annotation's into a 'Doc'ument containing
 --   color information.
-type Style = Doc Annotation -> Doc AnsiStyle
+type Style a = Annotation a -> AnsiStyle
 
 -------------------------------------------
 
+-- | A style which disregards all annotations
+unadornedStyle :: Style a
+unadornedStyle = const mempty
+
 -- | The default style for diagnostics, where:
 --
 --   * 'Error.Diagnose.Report.This' markers are colored in red for errors and yellow for warnings
@@ -90,21 +96,20 @@ type Style = Doc Annotation -> Doc AnsiStyle
 --   * File names are output in dull green
 --   * The @[error]@/@[warning]@ at the top is colored in red for errors and yellow for warnings
 --   * The code is output in normal white
-defaultStyle :: Style
+defaultStyle :: Style AnsiStyle
-defaultStyle = reAnnotate style
+defaultStyle = \case
-  where
+    ThisColor isError -> color if isError then Red else Yellow
-    style = \case
+    MaybeColor -> color Magenta
-      ThisColor isError -> color if isError then Red else Yellow
+    WhereColor -> colorDull Blue
-      MaybeColor -> color Magenta
+    HintColor -> color Cyan
-      WhereColor -> colorDull Blue
+    FileColor -> bold <> colorDull Green
-      HintColor -> color Cyan
+    RuleColor -> bold <> color Black
-      FileColor -> bold <> colorDull Green
+    KindColor isError -> bold <> defaultStyle (ThisColor isError)
-      RuleColor -> bold <> color Black
+    NoLineColor -> bold <> colorDull Magenta
-      KindColor isError -> bold <> style (ThisColor isError)
+    MarkerStyle st ->
-      NoLineColor -> bold <> colorDull Magenta
+      let ann = defaultStyle st
-      MarkerStyle st ->
+       in if ann == defaultStyle CodeStyle
-        let ann = style st
+            then ann
-         in if ann == style CodeStyle
+            else bold <> ann
-              then ann
+    CodeStyle -> color White
-              else bold <> ann
+    OtherStyle s -> s
-      CodeStyle -> color White

test/megaparsec/Repro6.hs

@@ -44,12 +44,12 @@ main = do
                 content3
 
   case res1 of
-    Left diag -> printDiagnostic stdout True True 4 defaultStyle (addFile diag filename (Text.unpack content1) :: Diagnostic String)
+    Left diag -> printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle (addFile diag filename (Text.unpack content1) :: Diagnostic String)
     Right res -> print res
   case res2 of
-    Left diag -> printDiagnostic stdout True True 4 defaultStyle (addFile diag filename (Text.unpack content2) :: Diagnostic String)
+    Left diag -> printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle (addFile diag filename (Text.unpack content2) :: Diagnostic String)
     Right res -> print res
   putStrLn "------------- res3 ----------------"
   case res3 of
-    Left diag -> printDiagnostic stdout True True 4 defaultStyle (addFile diag filename (Text.unpack content3) :: Diagnostic String)
+    Left diag -> printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle (addFile diag filename (Text.unpack content3) :: Diagnostic String)
     Right res -> print res

test/megaparsec/Spec.hs

@@ -16,7 +16,6 @@ import Error.Diagnose.Compat.Megaparsec
 import Instances ()
 import qualified Repro6
 import qualified Text.Megaparsec as MP
-import qualified Text.Megaparsec.Char as MP
 import qualified Text.Megaparsec.Char.Lexer as MP
 
 main :: IO ()
@@ -29,11 +28,11 @@ main = do
       res2 = first (errorDiagnosticFromBundle Nothing "Parse error on input" Nothing) $ MP.runParser @Void (MP.some MP.decimal <* MP.eof) filename content2
 
   case res1 of
-    Left diag -> printDiagnostic stdout True True 4 defaultStyle (addFile diag filename (Text.unpack content1) :: Diagnostic String)
+    Left diag -> printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle (addFile diag filename (Text.unpack content1) :: Diagnostic String)
-    Right res -> print res
+    Right res -> print @[Integer] res
   case res2 of
-    Left diag -> printDiagnostic stdout True True 4 defaultStyle (addFile diag filename (Text.unpack content2) :: Diagnostic String)
+    Left diag -> printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle (addFile diag filename (Text.unpack content2) :: Diagnostic String)
-    Right res -> print res
+    Right res -> print @[Integer] res
 
   putStrLn "---------------------------------------------------"
 

test/parsec/Repro2.hs

@@ -29,8 +29,8 @@ parser2 = op' "\\" *> letter
 
 main :: IO ()
 main = do
-  either (printDiagnostic stderr True True 4 defaultStyle) print $ diagParse parser1 "issues/2.txt" "\\1"
+  either (printDiagnostic stderr WithUnicode (TabSize 4) defaultStyle) print $ diagParse parser1 "issues/2.txt" "\\1"
-  either (printDiagnostic stderr True True 4 defaultStyle) print $ diagParse parser2 "issues/2.txt" "\\1"
+  either (printDiagnostic stderr WithUnicode (TabSize 4) defaultStyle) print $ diagParse parser2 "issues/2.txt" "\\1"
 
 -- smaller example
 op' :: String -> Parser String

test/parsec/Spec.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
 
 {-# OPTIONS -Wno-orphans #-}
 
@@ -32,13 +31,13 @@ main = do
       res3 = first (errorDiagnosticFromParseError Nothing "Parse error on input" Nothing) $ P.parse (test1 <* P.eof) filename content3
 
   case res1 of
-    Left diag -> printDiagnostic stdout True True 4 defaultStyle (addFile diag filename (Text.unpack content1) :: Diagnostic String)
+    Left diag -> printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle (addFile diag filename (Text.unpack content1) :: Diagnostic String)
     Right res -> print res
   case res2 of
-    Left diag -> printDiagnostic stdout True True 4 defaultStyle (addFile diag filename (Text.unpack content2) :: Diagnostic String)
+    Left diag -> printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle (addFile diag filename (Text.unpack content2) :: Diagnostic String)
     Right res -> print res
   case res3 of
-    Left diag -> printDiagnostic stdout True True 4 defaultStyle (addFile diag filename (Text.unpack content3) :: Diagnostic String)
+    Left diag -> printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle (addFile diag filename (Text.unpack content3) :: Diagnostic String)
     Right res -> print res
 
   -- all issue reproduction

test/rendering/Spec.hs

@@ -1,14 +1,17 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE ParallelListComp #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
 #ifdef USE_AESON
 import qualified Data.ByteString.Lazy as BS
+import Error.Diagnose(diagnosticToJson)
 #endif
 import Data.HashMap.Lazy (HashMap)
 import qualified Data.HashMap.Lazy as HashMap
 import Error.Diagnose
   ( Marker (..),
-    Note (Hint),
+    Note (..),
     Position (..),
     Report(..),
     addFile,
@@ -16,9 +19,17 @@ import Error.Diagnose
     def,
     defaultStyle,
     printDiagnostic,
+    printDiagnostic',
     stdout,
+    WithUnicode (..),
+    TabSize (..),
   )
 import System.IO (hPutStrLn)
+import Prettyprinter (Doc, annotate, pretty, hsep, indent, vsep, nest, (<+>), align, list)
+import Prettyprinter.Util (reflow)
+import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), color, bold, italicized, underlined)
+import Data.Traversable (mapAccumL)
+import Data.Functor.Compose (Compose(..))
 
 main :: IO ()
 main = do
@@ -73,19 +84,119 @@ main = do
           errorWithBlankAndNormalMarkerInLine,
           beautifulExample
         ]
+      customAnnReports =
+        [ colorfulReport,
+          indentedReport,
+          nestingReport
+        ]
 
   let diag = HashMap.foldlWithKey' addFile (foldl addReport def reports) files
+      customDiag = HashMap.foldlWithKey' addFile (foldl addReport def customAnnReports) files
 
   hPutStrLn stdout "\n\nWith unicode: ─────────────────────────\n"
-  printDiagnostic stdout True True 4 defaultStyle diag
+  printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle diag
   hPutStrLn stdout "\n\nWithout unicode: ----------------------\n"
-  printDiagnostic stdout False True 4 defaultStyle diag
+  printDiagnostic stdout WithoutUnicode (TabSize 4) defaultStyle diag
+  hPutStrLn stdout "\n\nWith custom annotations: ----------------------\n"
+  printDiagnostic' stdout WithUnicode (TabSize 4) defaultStyle customDiag
 #ifdef USE_AESON
   hPutStrLn stdout "\n\nAs JSON: ------------------------------\n"
   BS.hPutStr stdout (diagnosticToJson diag)
 #endif
   hPutStrLn stdout "\n"
 
+colorfulReport :: Report (Doc AnsiStyle)
+colorfulReport =
+  fmap hsep
+    . getCompose
+    . snd
+    . mapAccumL
+      (\(c : cs) s -> (cs, annotate c (pretty s)))
+      styles
+    . Compose
+    . fmap words
+    $ realWorldExample
+ where
+  styles = [ color fg <> e
+      | fg <- cycle [Black, Red, Green, Yellow, Blue, Magenta, Cyan, White]
+      | e <- cycle [bold, italicized, underlined]
+      ]
+
+indentedReport :: Report (Doc AnsiStyle)
+indentedReport =
+  Err
+    Nothing
+    ("Indent..." <> indent 3 (vsep ["foo", "bar", "baz"]))
+    [ (Position (1, 15) (1, 16) "test.zc", Maybe a)
+    , (Position (1, 11) (1, 12) "test.zc", This b)
+    ]
+    [Note c]
+ where
+  a =
+    vsep
+      [ "A woman’s face with Nature’s own hand painted"
+      , "Hast thou, the master-mistress of my passion;"
+      , "A woman’s gentle heart, but not acquainted"
+      , "With shifting change, as is false women’s fashion;"
+      ]
+  b =
+    vsep
+      [ "An eye more bright than theirs, less false in rolling,"
+      , "Gilding the object whereupon it gazeth;"
+      , "A man in hue, all “hues” in his controlling,"
+      , "Which steals men’s eyes and women’s souls amazeth."
+      ]
+  c =
+    vsep
+      [ "And for a woman wert thou first created;"
+      , "Till Nature, as she wrought thee, fell a-doting,"
+      , "And by addition me of thee defeated,"
+      , "By adding one thing to my purpose nothing."
+      , indent 4 "But since she prick’d thee out for women’s pleasure,"
+      , indent 4 "Mine be thy love and thy love’s use their treasure."
+      ]
+
+nestingReport :: Report (Doc AnsiStyle)
+nestingReport =
+  Err
+    Nothing
+    (nest 4 $ vsep ["Nest...", "foo", "bar", "baz"])
+    [ (Position (1, 15) (1, 16) "test.zc", Maybe a)
+    ]
+    [Note b, Hint c]
+ where
+  a =
+    nest 3 $
+      vsep
+        [ "'What day is it?' asked Pooh."
+        , "'It's today,' squeaked Piglet."
+        , "'My favourite day,' said Pooh."
+        ]
+  b =
+    foldr1
+      (\p q -> nest 2 (vsep [p, q]))
+      [ "It's a very funny thought that, if Bears were Bees,"
+      , "They'd build their nests at the bottom of trees."
+      , "And that being so (if the Bees were Bears),"
+      , "We shouldn't have to climb up all these stairs."
+      ]
+  c =
+    "The elements:"
+      <+> align
+        ( list
+            [ "antimony"
+            , "arsenic"
+            , "aluminum"
+            , "selenium"
+            , "hydrogen"
+            , "oxygen"
+            , "nitrogen"
+            , "rhenium"
+            , align $ reflow "And there may be many others, but they haven't been discovered"
+            ]
+        )
+
+
 errorNoMarkersNoHints :: Report String
 errorNoMarkersNoHints =
   Err