diagnose 2.4.0 → 2.5.0

raw patch · 14 files changed

+371/−218 lines, 14 filesdep ~aesondep ~prettyprinter-ansi-terminaldep ~unordered-containersPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, prettyprinter-ansi-terminal, unordered-containers

API changes (from Hackage documentation)

Files

• README.md +5/−4
• diagnose.cabal +18/−18
• src/Error/Diagnose.hs +2/−2
• src/Error/Diagnose/Diagnostic.hs +4/−1
• src/Error/Diagnose/Diagnostic/Internal.hs +57/−22
• src/Error/Diagnose/Position.hs +1/−4
• src/Error/Diagnose/Pretty.hs +0/−1
• src/Error/Diagnose/Report/Internal.hs +125/−121
• src/Error/Diagnose/Style.hs +32/−26
• test/megaparsec/Repro6.hs +3/−3
• test/megaparsec/Spec.hs +4/−5
• test/parsec/Repro2.hs +2/−2
• test/parsec/Spec.hs +3/−4
• test/rendering/Spec.hs +115/−5

@@ -39,7 +39,8 @@ A diagnostic can be viewed as a collection of reports, spanning on files. This is what the `Diagnostic` type embodies. -It has a `Default` instance, which can be used to construct an empty diagnostic (contains no reports, and has no files).+It is an instance of `Monoid`, which can be used to construct an empty+diagnostic (contains no reports, and has no files).  The second step is to add some reports. There are two kinds of reports:@@ -99,11 +100,11 @@         -- ^^^^ This is a 'Note' not a 'Hint', as specified by its 'IsString' instance  -- Create the diagnostic-let diagnostic  = addFile def "somefile.zc" "let id<a>(x : a) : a := x\n  + 1"+let diagnostic  = addFile mempty "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).

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.7.+-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- 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.@@ -71,14 +71,15 @@     , dlist ==1.0.*     , hashable >=1.3 && <2     , prettyprinter >=1.7.0 && <2-    , prettyprinter-ansi-terminal >=1.1.0 && <2+    , prettyprinter-ansi-terminal >=1.1.2 && <2     , text >=1.0.0.0 && <=2.0-    , unordered-containers ==0.2.*+    , unordered-containers >=0.2.11 && <0.3     , wcwidth >=0.0.1 && <1+  default-language: Haskell2010   if flag(json)     cpp-options: -DUSE_AESON     build-depends:-        aeson >=1.5 && <2+        aeson >=1.5 && <3       , bytestring >=0.9 && <1   if flag(megaparsec-compat)     build-depends:@@ -93,7 +94,6 @@   if flag(parsec-compat)     exposed-modules:         Error.Diagnose.Compat.Parsec-  default-language: Haskell2010  test-suite diagnose-megaparsec-tests   type: exitcode-stdio-1.0@@ -117,14 +117,15 @@     , dlist ==1.0.*     , hashable >=1.3 && <2     , prettyprinter >=1.7.0 && <2-    , prettyprinter-ansi-terminal >=1.1.0 && <2+    , prettyprinter-ansi-terminal >=1.1.2 && <2     , text >=1.2 && <3-    , unordered-containers ==0.2.*+    , unordered-containers >=0.2.11 && <0.3     , wcwidth >=0.0.1 && <1+  default-language: Haskell2010   if flag(json)     cpp-options: -DUSE_AESON     build-depends:-        aeson >=1.5 && <2+        aeson >=1.5 && <3       , bytestring >=0.9 && <1   if flag(megaparsec-compat)     build-depends:@@ -135,7 +136,6 @@         parsec >=3.1.14   if !(flag(megaparsec-compat))     buildable: False-  default-language: Haskell2010  test-suite diagnose-parsec-tests   type: exitcode-stdio-1.0@@ -158,14 +158,15 @@     , dlist ==1.0.*     , hashable >=1.3 && <2     , prettyprinter >=1.7.0 && <2-    , prettyprinter-ansi-terminal >=1.1.0 && <2+    , prettyprinter-ansi-terminal >=1.1.2 && <2     , text >=1.2 && <3-    , unordered-containers ==0.2.*+    , unordered-containers >=0.2.11 && <0.3     , wcwidth >=0.0.1 && <1+  default-language: Haskell2010   if flag(json)     cpp-options: -DUSE_AESON     build-depends:-        aeson >=1.5 && <2+        aeson >=1.5 && <3       , bytestring >=0.9 && <1   if flag(megaparsec-compat)     build-depends:@@ -176,7 +177,6 @@         parsec >=3.1.14   if !(flag(parsec-compat))     buildable: False-  default-language: Haskell2010  test-suite diagnose-rendering-tests   type: exitcode-stdio-1.0@@ -198,14 +198,15 @@     , dlist ==1.0.*     , hashable >=1.3 && <2     , prettyprinter >=1.7.0 && <2-    , prettyprinter-ansi-terminal >=1.1.0 && <2+    , prettyprinter-ansi-terminal >=1.1.2 && <2     , text >=1.0.0.0 && <=2.0-    , unordered-containers ==0.2.*+    , unordered-containers >=0.2.11 && <0.3     , wcwidth >=0.0.1 && <1+  default-language: Haskell2010   if flag(json)     cpp-options: -DUSE_AESON     build-depends:-        aeson >=1.5 && <2+        aeson >=1.5 && <3       , bytestring >=0.9 && <1   if flag(megaparsec-compat)     build-depends:@@ -214,4 +215,3 @@   if flag(parsec-compat)     build-depends:         parsec >=3.1.14-  default-language: Haskell2010

@@ -241,7 +241,7 @@ --   >            --   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 @@ --   >            --   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@:

@@ -20,12 +20,15 @@ #endif     addFile,     addReport,-    def,     errorsToWarnings,     hasReports,     reportsOf,     prettyDiagnostic,+    prettyDiagnostic',     printDiagnostic,+    printDiagnostic',     warningsToErrors,+    WithUnicode(..),+    TabSize(..),   ) import System.IO as Export (stderr, stdout)

@@ -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, WithUnicode(..), TabSize(..)) where  import Control.Monad.IO.Class (MonadIO, liftIO) #ifdef USE_AESON@@ -24,21 +25,20 @@ import Data.Array (listArray) import Data.DList (DList) import qualified Data.DList as DL-import Data.Default (Default, def) 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. -----   The constructors are private, but users can use 'def' from the 'Default' typeclass---   to create a new empty diagnostic, and 'addFile' and 'addReport' to alter its internal state.+--   Users can use 'mempty' to create a new empty diagnostic, and 'addFile' and+--   'addReport' to alter its internal state. data Diagnostic msg   = Diagnostic       (DList (Report msg))@@ -47,12 +47,13 @@       --   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+instance Monoid (Diagnostic msg) where+  mempty = Diagnostic mempty mempty  instance Semigroup (Diagnostic msg) where-  Diagnostic rs1 file <> Diagnostic rs2 _ = Diagnostic (rs1 <> rs2) file+  Diagnostic rs1 files1 <> Diagnostic rs2 files2 = Diagnostic (rs1 <> rs2) (files1 <> files2)  #ifdef USE_AESON instance ToJSON msg => ToJSON (Diagnostic msg) where@@ -98,35 +99,69 @@ 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 ::

@@ -41,10 +41,7 @@     -- | The file this position spans in.     file :: FilePath   }-  deriving (Show, Eq, Generic)--instance Ord Position where-  Position b1 e1 _ `compare` Position b2 e2 _ = (b1, e1) `compare` (b2, e2)+  deriving (Show, Eq, Ord, Generic)  instance Pretty Position where   pretty (Position (bl, bc) (el, ec) f) = pretty f <> at <> pretty bl <> colon <> pretty bc <> dash <> pretty el <> colon <> pretty ec

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

@@ -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@@ -36,19 +39,18 @@ import Data.Default (def) import Data.Foldable (fold) import Data.Function (on)-import Data.Functor ((<&>))+import Data.Functor ((<&>), void) import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap import qualified Data.List as List import qualified Data.List.Safe as List import Data.Maybe-import Data.Ord (Down (Down)) 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.Internal (Doc (..))+import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>), reAnnotate, SimpleDocStream (..), layoutCompact)+import Prettyprinter.Internal (Doc (..), textSpaces)+import Data.Bool (bool)  type FileMap = HashMap FilePath (Array Int String) @@ -67,6 +69,7 @@       -- ^ 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,26 +123,12 @@     Maybe msg   | -- | An empty marker, whose sole purpose is to include a line of code in the report without markers under.     Blank--instance Eq (Marker msg) where-  This _ == This _ = True-  Where _ == Where _ = True-  Maybe _ == Maybe _ = True-  Blank == Blank = True-  _ == _ = False-  {-# INLINEABLE (==) #-}--instance Ord (Marker msg) where-  This _ < _ = False-  Where _ < This _ = True-  Where _ < _ = False-  Maybe _ < _ = True-  _ < Blank = True-  Blank < _ = False-  {-# INLINEABLE (<) #-}+  deriving (Eq, Ord, Functor, Foldable, Traversable) -  m1 <= m2 = m1 < m2 || m1 == m2-  {-# INLINEABLE (<=) #-}+isBlank :: Marker msg -> Bool+isBlank = \case+  Blank -> True+  _ -> False  -- | A note is a piece of information that is found at the end of a report. data Note msg@@ -147,6 +136,7 @@     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 +177,21 @@ 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 ->-  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@@ -219,7 +212,7 @@                  )               <> 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 +227,7 @@               (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 +239,7 @@         <> {- (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 +261,11 @@   -- | The length of the left space before the bullet.   Int ->   -- | Whether to print with unicode characters or not.-  Bool ->-  Doc Annotation-dotPrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (if withUnicode then "•" else ":")+  WithUnicode ->+  Doc (Annotation ann)+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 +278,9 @@   -- | The length of the left space before the pipe.   Int ->   -- | Whether to print with unicode characters or not.-  Bool ->-  Doc Annotation-pipePrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (if withUnicode then "│" else "|")+  WithUnicode ->+  Doc (Annotation ann)+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 +297,11 @@   -- | The line number to show.   Int ->   -- | Whether to use unicode characters or not.-  Bool ->-  Doc Annotation+  WithUnicode ->+  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 +312,11 @@ --   [without unicode] "@␣␣␣␣...@" ellipsisPrefix ::   Int ->-  Bool ->-  Doc Annotation-ellipsisPrefix leftLen withUnicode = pad leftLen ' ' mempty <> annotate RuleColor (if withUnicode then space <> "⋮" else "...")+  WithUnicode ->+  Doc (Annotation ann)+ellipsisPrefix leftLen withUnicode = pad leftLen ' ' mempty <> annotate RuleColor (unicode "..." (space <> "⋮") withUnicode)  groupMarkersPerFile ::-  Pretty msg =>   [(Position, Marker msg)] ->   [(Bool, [(Position, Marker msg)])] groupMarkersPerFile [] = []@@ -346,29 +340,28 @@  -- | 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)] ->-  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        sortedMarkersPerLine = {- second (List.sortOn (first $ snd . begin)) <$> -} List.sortOn fst (HashMap.toList markersPerLine) -      reportFile = maybe (pretty @Position def) (pretty . fst) $ List.safeHead (List.sortOn (Down . snd) markers)+      reportFile = maybe (pretty @Position def) (pretty . fst) $ List.safeHead (List.sortOn (void . snd) markers)       -- the reported file is the file of the first 'This' marker (only one must be present)        allLineNumbers = List.sort $ List.nub $ (fst <$> sortedMarkersPerLine) <> (multilineMarkers >>= \(Position (bl, _) (el, _) _, _) -> [bl .. el])@@ -377,16 +370,16 @@         ( 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 (if withUnicode then "┼──▶" else "+-->")+                <> annotate RuleColor (pad (maxLineNumberLength + 2) (unicode '-' '─' withUnicode) mempty)+                <> 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 +397,16 @@  -- | prettyAllLines ::-  Pretty msg =>   FileMap ->-  Bool ->+  WithUnicode ->   Bool ->   -- | The number of spaces each TAB character will span-  Int ->+  TabSize ->   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     [] ->@@ -450,38 +442,35 @@           -- take the first multiline marker to color the entire line, if there is one            (multilineEndingOnLine, otherMultilines) = flip List.partition multiline \(Position _ (el, _) _, _) -> el == line+          shouldShowMultiLine = isLastLine+            || ((==) `on` fmap (fmap void)) (List.safeLast multilineEndingOnLine) (List.safeLast multiline)            !additionalPrefix = case allMultilineMarkersInLine of             [] ->               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-                          | hasPredecessor && withUnicode -> "├"-                          | hasPredecessor -> "|"-                          | withUnicode -> "╭"-                          | otherwise -> "+"-                    )-                    <> annotate (markerColor isError marker) (if withUnicode then "┤" else ">")+                    (unicode (bool "+" "|" hasPredecessor ) (bool "╭" "├" hasPredecessor) withUnicode)+                    <> annotate (markerColor isError marker) (unicode ">" "┤" withUnicode)                     <> space            -- we need to remove all blank markers because they are irrelevant to the display-          allInlineMarkersInLine' = filter ((/=) Blank . snd) allInlineMarkersInLine-          allMultilineMarkersSpanningLine' = filter ((/=) Blank . snd) allMultilineMarkersSpanningLine+          allInlineMarkersInLine' = filter (not . isBlank . snd) allInlineMarkersInLine+          allMultilineMarkersSpanningLine' = filter (not . isBlank . snd) allMultilineMarkersSpanningLine            (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+              <> showMultiline shouldShowMultiLine multilineEndingOnLine           )      showMultiline _ [] = mempty@@ -489,33 +478,33 @@       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 "`- "-                  else if withUnicode then "├╸ " else "|- "+                  then unicode "`- " "╰╸ " withUnicode+                  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)-getLine_ files markers line tabSize isError =+  (WidthTable, Doc (Annotation ann))+getLine_ files markers line (TabSize tabSize) isError =   case safeArrayIndex (line - 1) =<< (HashMap.!?) files . file . fst =<< List.safeHead markers of     Nothing ->       ( mkWidthTable "",@@ -548,12 +537,12 @@     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@@ -566,7 +555,7 @@     showMarkers n lineLen       | n > lineLen = mempty -- reached the end of the line       | otherwise =-        let allMarkers = flip filter ms \(Position (_, bc) (_, ec) _, mark) -> mark /= Blank && n >= bc && n < ec+        let allMarkers = flip filter ms \(Position (_, bc) (_, ec) _, mark) -> not (isBlank mark) && n >= bc && n < ec          in -- only consider markers which span onto the current column             case allMarkers of               [] -> fold (replicate (widthAt n) space) <> showMarkers (n + 1) lineLen@@ -574,15 +563,15 @@                 annotate                   (markerColor isError marker)                   ( if snd begin == n-                      then (if withUnicode then "┬" else "^") <> fold (replicate (widthAt n - 1) if withUnicode then "─" else "-")-                      else fold (replicate (widthAt n) if withUnicode then "─" else "-")+                      then unicode "^" "┬" withUnicode <> fold (replicate (widthAt n - 1) (unicode "-" "─" withUnicode))+                      else fold (replicate (widthAt n) (unicode "-" "─" withUnicode))                   )                   <> showMarkers (n + 1) lineLen      showMessages specialPrefix ms lineLen = case List.safeUncons ms of       Nothing -> mempty -- no more messages to show       Just ((Position b@(_, bc) _ _, msg), pipes) ->-        let filteredPipes = filter (uncurry (&&) . bimap ((/= b) . begin) (/= Blank)) pipes+        let filteredPipes = filter (uncurry (&&) . bimap ((/= b) . begin) (not . isBlank)) pipes             -- record only the pipes corresponding to markers on different starting positions             nubbedPipes = List.nubBy ((==) `on` (begin . fst)) filteredPipes             -- and then remove all duplicates@@ -606,7 +595,7 @@               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 +604,56 @@                     Nothing -> 0                     Just col -> widthsBetween bc col -                  currentPipe =-                    if-                        | withUnicode && hasSuccessor -> "├"-                        | withUnicode -> "╰"-                        | hasSuccessor -> "|"-                        | otherwise -> "`"+                  currentPipe = unicode (bool "`" "|" hasSuccessor) (bool "╰" "├" hasSuccessor) withUnicode -                  lineChar = if withUnicode then '─' else '-'-                  pointChar = if withUnicode then "╸" else "-"+                  lineChar = unicode '-' '─' withUnicode+                  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 -> Doc ann -> Doc ann-replaceLinesWith repl Line = repl-replaceLinesWith _ Fail = Fail-replaceLinesWith _ Empty = Empty-replaceLinesWith _ (Char c) = Char c-replaceLinesWith repl (Text _ s) =-  let lines = Text.split (== '\n') s <&> \txt -> Text (Text.length txt) txt-   in mconcat (List.intersperse repl lines)-replaceLinesWith repl (FlatAlt f d) = FlatAlt (replaceLinesWith repl f) (replaceLinesWith repl d)-replaceLinesWith repl (Cat c d) = Cat (replaceLinesWith repl c) (replaceLinesWith repl d)-replaceLinesWith repl (Nest n d) = Nest n (replaceLinesWith repl d)-replaceLinesWith repl (Union c d) = Union (replaceLinesWith repl c) (replaceLinesWith repl d)-replaceLinesWith repl (Column f) = Column (replaceLinesWith repl . f)-replaceLinesWith repl (Nesting f) = Nesting (replaceLinesWith repl . f)-replaceLinesWith repl (Annotated ann doc) = Annotated ann (replaceLinesWith repl doc)-replaceLinesWith repl (WithPageWidth f) = WithPageWidth (replaceLinesWith repl . f)+replaceLinesWith :: Doc ann -> Int -> Doc ann -> Doc ann+replaceLinesWith repl = go+ where+  replWidth = sdsWidth . layoutCompact $ repl+  sdsWidth = \case+    SFail -> 0+    SEmpty -> 0+    SChar _ sds -> 1 + sdsWidth sds+    SText l _ sds -> l + sdsWidth sds+    SLine _ _ -> error "replaceLinesWith was given a prefix with a line break"+    SAnnPush _ sds -> sdsWidth sds+    SAnnPop sds -> sdsWidth sds+  replWithNesting n = hardline <> repl <> pretty (textSpaces n)+  go n = \case+    Line -> replWithNesting n+    Fail -> Fail+    Empty -> Empty+    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 +663,7 @@   -- | 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 +679,15 @@ {-# 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-   in prefix <+> annotate HintColor (notePrefix h <+> replaceLinesWith (prefix <+> "      ") (pretty $ noteMessage h))+  let prefix = space <> pipePrefix leftLen withUnicode+   in hardline <> prefix <+> annotate HintColor (notePrefix h <+> replaceLinesWith prefix 7 (annotated $ noteMessage h))         <> prettyAllHints hs leftLen withUnicode   where     notePrefix (Note _) = "Note:"@@ -704,3 +700,11 @@ 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

@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveGeneric #-} -- | -- Module      : Error.Diagnose.Style -- Description : Custom style definitions@@ -11,15 +13,13 @@     Style,     -- $defining_new_styles -    -- * Default style specification+    -- * Styles     defaultStyle,--    -- * Re-exports-    reAnnotate,+    unadornedStyle,   ) where -import Prettyprinter (Doc, reAnnotate)+import GHC.Generics import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), bold, color, colorDull)  -- $defining_new_styles@@ -41,7 +41,7 @@ -- 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 +67,25 @@   | -- | 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 (Eq, Ord, Show, Generic, 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 +97,20 @@ --   * 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 = reAnnotate style-  where-    style = \case-      ThisColor isError -> color if isError then Red else Yellow-      MaybeColor -> color Magenta-      WhereColor -> colorDull Blue-      HintColor -> color Cyan-      FileColor -> bold <> colorDull Green-      RuleColor -> bold <> color Black-      KindColor isError -> bold <> style (ThisColor isError)-      NoLineColor -> bold <> colorDull Magenta-      MarkerStyle st ->-        let ann = style st-         in if ann == style CodeStyle-              then ann-              else bold <> ann-      CodeStyle -> color White+defaultStyle :: Style AnsiStyle+defaultStyle = \case+    ThisColor isError -> color if isError then Red else Yellow+    MaybeColor -> color Magenta+    WhereColor -> colorDull Blue+    HintColor -> color Cyan+    FileColor -> bold <> colorDull Green+    RuleColor -> bold <> color Black+    KindColor isError -> bold <> defaultStyle (ThisColor isError)+    NoLineColor -> bold <> colorDull Magenta+    MarkerStyle st ->+      let ann = defaultStyle st+       in if ann == defaultStyle CodeStyle+            then ann+            else bold <> ann+    CodeStyle -> color White+    OtherStyle s -> s

@@ -44,12 +44,12 @@                 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

@@ -16,7 +16,6 @@ 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 @@       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)-    Right res -> print res+    Left diag -> printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle (addFile diag filename (Text.unpack content1) :: Diagnostic String)+    Right res -> print @[Integer] res   case res2 of-    Left diag -> printDiagnostic stdout True True 4 defaultStyle (addFile diag filename (Text.unpack content2) :: Diagnostic String)-    Right res -> print res+    Left diag -> printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle (addFile diag filename (Text.unpack content2) :: Diagnostic String)+    Right res -> print @[Integer] res    putStrLn "---------------------------------------------------" 

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

@@ -3,7 +3,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}  {-# OPTIONS -Wno-orphans #-} @@ -32,13 +31,13 @@       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

@@ -1,24 +1,34 @@ {-# 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,     addReport,-    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,18 +83,118 @@           errorWithBlankAndNormalMarkerInLine,           beautifulExample         ]+      customAnnReports =+        [ colorfulReport,+          indentedReport,+          nestingReport+        ] -  let diag = HashMap.foldlWithKey' addFile (foldl addReport def reports) files+  let diag = HashMap.foldlWithKey' addFile (foldl addReport mempty reports) files+      customDiag = HashMap.foldlWithKey' addFile (foldl addReport mempty 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 =