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
-printDiagnostic stdout True True 4 defaultStyle diagnostic'
+-- Print with unicode characters, and the default (colorful) style
+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.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.
@@ -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
-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?
+  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 ->
-  -- | 'False' to disable colors.
-  Bool ->
+  WithUnicode ->
   -- | 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 =
-  liftIO $ hPutDoc handle ((if withColors then style else unAnnotate) $ prettyDiagnostic withUnicode tabSize diag)
+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?
+  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