Add functionality to render diagnostics with user provided Docs

src/Error/Diagnose/Diagnostic.hs

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

src/Error/Diagnose/Diagnostic/Internal.hs

@@ -34,8 +34,8 @@ import Data.List (intersperse)
 import Error.Diagnose.Report (Report)
 import Error.Diagnose.Report.Internal (FileMap, errorToWarning, prettyReport, warningToError)
 import Error.Diagnose.Style (Annotation, Style)
-import Prettyprinter (Doc, Pretty, hardline, unAnnotate)
-import Prettyprinter.Render.Terminal (hPutDoc)
+import Prettyprinter (Doc, Pretty, hardline, pretty, defaultLayoutOptions, reAnnotateS, layoutPretty)
+import Prettyprinter.Render.Terminal (renderIO)
 import System.IO (Handle)
 
 -- | The data type for diagnostic containing messages of an abstract type.
@@ -107,11 +107,25 @@ prettyDiagnostic ::
   Int ->
   -- | The diagnostic to print.
   Diagnostic msg ->
-  Doc Annotation
-prettyDiagnostic withUnicode tabSize (Diagnostic reports file) =
-  fold . intersperse hardline $ prettyReport file withUnicode tabSize <$> toList reports
+  Doc (Annotation ann)
+prettyDiagnostic withUnicode tabSize =
+  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?
+  Bool ->
+  -- | The number of spaces each TAB character will span.
+  Int ->
+  -- | 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) =>
@@ -119,18 +133,38 @@ printDiagnostic ::
   Handle ->
   -- | Should we print with unicode characters?
   Bool ->
-  -- | 'False' to disable colors.
+  -- | The number of spaces each TAB character will span.
+  Int ->
+  -- | The style in which to output the diagnostic.
+  Style ann ->
+  -- | The diagnostic to output.
+  Diagnostic msg ->
+  m ()
+printDiagnostic handle withUnicode tabSize style =
+  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?
   Bool ->
   -- | The number of spaces each TAB character will span.
   Int ->
   -- | The style in which to output the diagnostic.
-  Style ->
+  Style ann ->
   -- | The diagnostic to output.
-  Diagnostic msg ->
+  Diagnostic (Doc ann) ->
   m ()
-printDiagnostic handle withUnicode withColors tabSize style diag =
-  liftIO $ hPutDoc handle ((if withColors then style else unAnnotate) $ prettyDiagnostic withUnicode tabSize diag)
-{-# INLINE printDiagnostic #-}
+printDiagnostic' handle withUnicode tabSize style =
+  liftIO
+    . renderIO handle
+    . reAnnotateS style
+    . layoutPretty defaultLayoutOptions
+    . prettyDiagnostic' withUnicode tabSize
 
 -- | Inserts a new referenceable file within the diagnostic.
 addFile ::

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

@@ -50,7 +50,7 @@ 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)
 import Prettyprinter.Internal (Doc (..))
 
 type FileMap = HashMap FilePath (Array Int String)
@@ -195,7 +195,6 @@ errorToWarning r@(Report False _ _ _ _) = r
 
 -- | 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?
@@ -203,8 +202,8 @@ prettyReport ::
   -- | The number of spaces each TAB character will span
   Int ->
   -- | The whole report to output
-  Report msg ->
-  Doc Annotation
+  Report (Doc ann) ->
+  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
@@ -225,7 +224,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:
@@ -240,7 +239,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
@@ -275,7 +274,7 @@ dotPrefix ::
   Int ->
   -- | Whether to print with unicode characters or not.
   Bool ->
-  Doc Annotation
+  Doc (Annotation ann)
 dotPrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (if withUnicode then "•" else ":")
 {-# INLINE dotPrefix #-}
 
@@ -290,7 +289,7 @@ pipePrefix ::
   Int ->
   -- | Whether to print with unicode characters or not.
   Bool ->
-  Doc Annotation
+  Doc (Annotation ann)
 pipePrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (if withUnicode then "│" else "|")
 {-# INLINE pipePrefix #-}
 
@@ -309,7 +308,7 @@ linePrefix ::
   Int ->
   -- | Whether to use unicode characters or not.
   Bool ->
-  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 "|"
@@ -324,11 +323,10 @@ linePrefix leftLen lineNo withUnicode =
 ellipsisPrefix ::
   Int ->
   Bool ->
-  Doc Annotation
+  Doc (Annotation ann)
 ellipsisPrefix leftLen withUnicode = pad leftLen ' ' mempty <> annotate RuleColor (if withUnicode then space <> "⋮" else "...")
 
 groupMarkersPerFile ::
-  Pretty msg =>
   [(Position, Marker msg)] ->
   [(Bool, [(Position, Marker msg)])]
 groupMarkersPerFile [] = []
@@ -352,7 +350,6 @@ 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?
@@ -366,8 +363,8 @@ prettySubReport ::
   -- | 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)] ->
-  Doc Annotation
+  [(Position, Marker (Doc ann))] ->
+  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
@@ -410,17 +407,16 @@ splitMarkersPerLine (m@(Position {..}, _) : ms) =
 
 -- |
 prettyAllLines ::
-  Pretty msg =>
   FileMap ->
   Bool ->
   Bool ->
   -- | The number of spaces each TAB character will span
   Int ->
   Int ->
-  [(Int, [(Position, Marker msg)])] ->
-  [(Position, Marker msg)] ->
+  [(Int, [(Position, Marker (Doc ann))])] ->
+  [(Position, Marker (Doc ann))] ->
   [Int] ->
-  Doc Annotation
+  Doc (Annotation ann)
 prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNumbers =
   case lineNumbers of
     [] ->
@@ -506,7 +502,7 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu
                   then if withUnicode then "╰╸ " else "`- "
                   else if withUnicode then "├╸ " else "|- "
               )
-                <> 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) (annotated $ markerMessage marker)
 
           showMultilineMarkerMessages [] = []
           showMultilineMarkerMessages [m] = [showMultilineMarkerMessage m True]
@@ -520,7 +516,7 @@ getLine_ ::
   Int ->
   Int ->
   Bool ->
-  (WidthTable, Doc Annotation)
+  (WidthTable, Doc (Annotation ann))
 getLine_ files markers line tabSize isError =
   case safeArrayIndex (line - 1) =<< (HashMap.!?) files . file . fst =<< List.safeHead markers of
     Nothing ->
@@ -554,7 +550,7 @@ 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)) -> Bool -> 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
@@ -640,7 +636,7 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn
 
                   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 (hardline <+> lineStart pipesBeforeMessageRendered <+> if List.null pipesBeforeMessageStart then "  " else " ") $ annotated $ markerMessage msg)
          in hardline <+> prefix <> showMessages specialPrefix pipes lineLen
 
 -- WARN: uses the internal of the library
@@ -673,7 +669,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
@@ -689,7 +685,7 @@ markerMessage Blank = undefined
 {-# INLINE markerMessage #-}
 
 -- | Pretty prints all hints.
-prettyAllHints :: Pretty msg => [Note msg] -> Int -> Bool -> Doc Annotation
+prettyAllHints :: [Note (Doc ann)] -> Int -> Bool -> Doc (Annotation ann)
 prettyAllHints [] _ _ = mempty
 prettyAllHints (h : hs) leftLen withUnicode =
   {-
@@ -697,7 +693,7 @@ prettyAllHints (h : hs) leftLen withUnicode =
         (1)         : Hint: <hint message>
   -}
   let prefix = hardline <+> pipePrefix leftLen withUnicode
-   in prefix <+> annotate HintColor (notePrefix h <+> replaceLinesWith (prefix <+> "      ") (pretty $ noteMessage h))
+   in prefix <+> annotate HintColor (notePrefix h <+> replaceLinesWith (prefix <+> "      ") (annotated $ noteMessage h))
         <> prettyAllHints hs leftLen withUnicode
   where
     notePrefix (Note _) = "Note:"
@@ -710,3 +706,6 @@ 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

src/Error/Diagnose/Style.hs

@@ -13,15 +13,12 @@ module Error.Diagnose.Style
     Style,
     -- $defining_new_styles
 
-    -- * Default style specification
+    -- * Styles
     defaultStyle,
-
-    -- * Re-exports
-    reAnnotate,
+    unadornedStyle,
   )
 where
 
-import Prettyprinter (Doc, reAnnotate)
 import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), bold, color, colorDull)
 
 -- $defining_new_styles
@@ -84,6 +81,10 @@ 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

test/rendering/Spec.hs

@@ -77,9 +77,9 @@ main = do
   let diag = HashMap.foldlWithKey' addFile (foldl addReport def reports) files
 
   hPutStrLn stdout "\n\nWith unicode: ─────────────────────────\n"
-  printDiagnostic stdout True True 4 defaultStyle diag
+  printDiagnostic stdout True 4 defaultStyle diag
   hPutStrLn stdout "\n\nWithout unicode: ----------------------\n"
-  printDiagnostic stdout False True 4 defaultStyle diag
+  printDiagnostic stdout False 4 defaultStyle diag
 #ifdef USE_AESON
   hPutStrLn stdout "\n\nAs JSON: ------------------------------\n"
   BS.hPutStr stdout (diagnosticToJson diag)