diagnose 1.9.0 → 2.0.0

raw patch · 17 files changed

+272/−71 lines, 17 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• README.md +9/−6
• diagnose.cabal +5/−2
• src/Error/Diagnose.hs +22/−5
• src/Error/Diagnose/Compat/Megaparsec.hs +1/−1
• src/Error/Diagnose/Compat/Parsec.hs +1/−1
• src/Error/Diagnose/Diagnostic.hs +1/−1
• src/Error/Diagnose/Diagnostic/Internal.hs +14/−9
• src/Error/Diagnose/Position.hs +1/−1
• src/Error/Diagnose/Report.hs +1/−1
• src/Error/Diagnose/Report/Internal.hs +33/−32
• src/Error/Diagnose/Style.hs +102/−0
• test/megaparsec/Instances.hs +11/−0
• test/megaparsec/Repro6.hs +55/−0
• test/megaparsec/Spec.hs +8/−5
• test/parsec/Repro2.hs +2/−2
• test/parsec/Spec.hs +2/−2
• test/rendering/Spec.hs +4/−3

@@ -27,6 +27,7 @@ - Support for optional custom error codes, if you want to go the Rust way - Variable width Unicode characters are handled in a crossplatform manner - TAB characters have custom sizes specified when printing a diagnostic, so that *you* decide the width of a TAB, not your terminal emulator!+- Colors can be tweaked thanks to the ability to export diagnostics as `Doc`uments  ## Usage @@ -77,8 +78,10 @@ Once your reports are created, you will need to add them inside the diagnostic using `addReport`. You will also need to put your files into the diagnostic with `addFile`, else lines won't be printed and you will get `<no-line>` in your reports. -After all of this is done, you may choose to either print the diagnostic onto a handle using `printDiagnostic`-or export it to JSON with `diagnosticToJson` or the `ToJSON` class of Aeson (the output format is documented under the `diagnosticToJson` function).+After all of this is done, you may choose to either:+- print the diagnostic onto a file `Handle` (most likely `stdout` or `stderr`) using `printDiagnostic`;+- create a `Doc`ument which can be further altered using `prettyDiagnostic`;+- or export it to JSON with `diagnosticToJson` or the `ToJSON` class of Aeson (the output format is documented under the `diagnosticToJson` function).  ## Example @@ -98,11 +101,11 @@ let diagnostic  = addFile def "somefile.zc" "let id<a>(x : a) : a := x\n  + 1" let diagnostic' = addReport diagnostic beautifulExample --- Print with unicode characters and colors-printDiagnostic stdout True True 4 diagnostic'+-- Print with unicode characters, colors and the default style+printDiagnostic stdout True True 4 defaultStyle diagnostic' ``` -More examples are given in the [`test/rendering`](./test/rendering) folder.+More examples are given in the [`test/rendering`](./test/rendering) folder (execute `stack test` to see the output).  ## TODO list @@ -112,4 +115,4 @@  This work is licensed under the BSD-3 clause license. -Copyright (c) 2021- Mesabloo, all rights reserved.+Copyright (c) 2021-2022 Mesabloo, all rights reserved.

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           diagnose-version:        1.9.0+version:        2.0.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.@@ -17,7 +17,7 @@ bug-reports:    https://github.com/mesabloo/diagnose/issues author:         Ghilain Bergeron maintainer:     Ghilain Bergeron-copyright:      2021- Ghilain Bergeron+copyright:      2021-2022 Ghilain Bergeron license:        BSD3 license-file:   LICENSE build-type:     Simple@@ -50,6 +50,7 @@       Error.Diagnose.Position       Error.Diagnose.Pretty       Error.Diagnose.Report+      Error.Diagnose.Style   other-modules:       Data.List.Safe       Error.Diagnose.Compat.Hints@@ -95,6 +96,8 @@   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:+      Instances+      Repro6       Paths_diagnose   hs-source-dirs:       test/megaparsec

@@ -10,9 +10,12 @@     -- ** Creating diagnostics from reports     -- $create_diagnostic -    -- *** Pretty-printing a diagnostic+    -- *** Pretty-printing a diagnostic onto a file 'System.IO.Handle'     -- $diagnostic_pretty +    -- *** Pretty-printing a diagnostic as a document+    -- $diagnostic_to_doc+     -- *** Exporting a diagnostic to JSON     -- $diagnostic_json @@ -37,6 +40,7 @@ import Error.Diagnose.Position as Export import Error.Diagnose.Pretty as Export import Error.Diagnose.Report as Export+import Error.Diagnose.Style as Export  -- $header --@@ -95,13 +99,13 @@ -- --   Markers put in the report can be one of (the colors specified are used only when pretty-printing): -----   - A 'This' marker, which is the primary marker of the report.+--   - A 'Error.Diagnose.Report.This' marker, which is the primary marker of the report. --     While it is allowed to have multiple of these inside one report, it is encouraged not to, because the position at the top of---     the report will only be the one of the /first/ 'This' marker, and because the resulting report may be harder to understand.+--     the report will only be the one of the /first/ 'Error.Diagnose.Report.This' marker, and because the resulting report may be harder to understand. -- --         This marker is output in red in an error report, and yellow in a warning report. -----   - A 'Where' marker contains additional information/provides context to the error/warning report.+--   - A 'Error.Diagnose.Report.Where' marker contains additional information/provides context to the error/warning report. --     For example, it may underline where a given variable @x@ is bound to emphasize it. -- --         This marker is output in blue.@@ -117,7 +121,8 @@ --   and returns a 'Diagnostic') to insert a new report inside the diagnostic, or 'addFile' (which takes a 'Diagnostic', a 'FilePath' and a @['String']@, --   and returns a 'Diagnostic') to insert a new file reference in the diagnostic. -----   You can then either pretty-print the diagnostic obtained (which requires all messages to be instances of the 'Text.PrettyPrint.ANSI.Leijen.Pretty')+--   You can then either pretty-print the diagnostic obtained (which requires all messages to be instances of the 'Prettyprinter.Pretty')+--   -- directly onto a file handle or as a plain 'Prettyprinter.Doc'ument -- --   or export it to a lazy JSON 'Data.Bytestring.Lazy.ByteString' (e.g. in a LSP context).  -- $diagnostic_pretty@@ -152,7 +157,19 @@ -- --   - A 'Int' describing the number of spaces with which to output a TAB character. --+--   - The 'Style' describing colors of the report.+--     See the module "Error.Diagnose.Style" for how to define new styles.+-- --   - And finally the 'Diagnostic' to output.++-- $diagnostic_to_doc+--+-- 'Diagnostic's can be “output” (at least ready to be rendered) to a 'Prettyprinter.Doc' using 'prettyDiagnostic', which allows it to be easily added to other 'Prettyprinter.Doc' outputs.+-- This makes it easy to customize the error messages further (though not the internal parts, only adding to it).+-- As a 'Prettyprinter.Doc', there is also the possibility of altering internal annotations (styles) much easier (although this is already possible when printing the diagnostic).+--+-- The arguments of the function mostly follow the ones from 'printDiagnostic'.+-- The style is not one, as it can be applied by simply applying the styling function to the resulting function (if wanted).  -- $diagnostic_json --

@@ -11,7 +11,7 @@ -- | -- Module      : Error.Diagnose.Compat.Megaparsec -- Description : Compatibility layer for megaparsec--- Copyright   : (c) Mesabloo, 2021+-- Copyright   : (c) Mesabloo, 2021-2022 -- License     : BSD3 -- Stability   : experimental -- Portability : Portable

@@ -7,7 +7,7 @@ -- | -- Module      : Error.Diagnose.Compat.Parsec -- Description : Compatibility layer for parsec--- Copyright   : (c) Mesabloo, 2021+-- Copyright   : (c) Mesabloo, 2021-2022 -- License     : BSD3 -- Stability   : experimental -- Portability : Portable

@@ -3,7 +3,7 @@ -- | -- Module      : Error.Diagnose.Diagnostic -- Description : Diagnostic definition and pretty printing--- Copyright   : (c) Mesabloo, 2021+-- Copyright   : (c) Mesabloo, 2021-2022 -- License     : BSD3 -- Stability   : experimental -- Portability : Portable

@@ -4,7 +4,7 @@ -- | -- Module      : Error.Diagnose.Diagnostic.Internal -- Description : Internal workings for diagnostic definitions and pretty printing.--- Copyright   : (c) Mesabloo, 2021+-- Copyright   : (c) Mesabloo, 2021-2022 -- License     : BSD3 -- Stability   : experimental -- Portability : Portable@@ -27,8 +27,9 @@ import Data.List (intersperse) import Error.Diagnose.Report (Report) import Error.Diagnose.Report.Internal (prettyReport)+import Error.Diagnose.Style (Annotation, Style) import Prettyprinter (Doc, Pretty, hardline, unAnnotate)-import Prettyprinter.Render.Terminal (AnsiStyle, hPutDoc)+import Prettyprinter.Render.Terminal (hPutDoc) import System.IO (Handle)  -- | The data type for diagnostic containing messages of an abstract type.@@ -69,6 +70,11 @@ --   If you do not want these, just 'unAnnotate' the resulting document like so: -- --   >>> let doc = unAnnotate (prettyDiagnostic withUnicode tabSize diagnostic)+--+--   Changing the style is also rather easy:+--+--   >>> let myCustomStyle :: Style = _+--   >>> let doc = myCustomStyle (prettyDiagnostic withUnicode tabSize diagnostic) prettyDiagnostic ::   Pretty msg =>   -- | Should we use unicode when printing paths?@@ -77,7 +83,7 @@   Int ->   -- | The diagnostic to print.   Diagnostic msg ->-  Doc AnsiStyle+  Doc Annotation prettyDiagnostic withUnicode tabSize (Diagnostic reports file) =   fold . intersperse hardline $ prettyReport file withUnicode tabSize <$> reports {-# INLINE prettyDiagnostic #-}@@ -93,14 +99,13 @@   Bool ->   -- | The number of spaces each TAB character will span.   Int ->+  -- | The style in which to output the diagnostic.+  Style ->   -- | The diagnostic to output.   Diagnostic msg ->   m ()-printDiagnostic handle withUnicode withColors tabSize diag =-  liftIO $ hPutDoc handle (unlessId withColors unAnnotate $ prettyDiagnostic withUnicode tabSize diag)-  where-    unlessId cond app = if cond then id else app-    {-# INLINE unlessId #-}+printDiagnostic handle withUnicode withColors tabSize style diag =+  liftIO $ hPutDoc handle ((if withColors then style else unAnnotate) $ prettyDiagnostic withUnicode tabSize diag) {-# INLINE printDiagnostic #-}  -- | Inserts a new referenceable file within the diagnostic.@@ -122,7 +127,7 @@   Report msg ->   Diagnostic msg addReport (Diagnostic reports files) report =-  Diagnostic (report : reports) files+  Diagnostic (reports <> [report]) files {-# INLINE addReport #-}  #ifdef USE_AESON

@@ -7,7 +7,7 @@ -- | -- Module      : Error.Diagnose.Diagnostic -- Description : Defines location information as a simple record.--- Copyright   : (c) Mesabloo, 2021+-- Copyright   : (c) Mesabloo, 2021-2022 -- License     : BSD3 -- Stability   : experimental -- Portability : Portable

@@ -1,7 +1,7 @@ -- | -- Module      : Error.Diagnose.Report -- Description : Report definition and pretty printing--- Copyright   : (c) Mesabloo, 2021+-- Copyright   : (c) Mesabloo, 2021-2022 -- License     : BSD3 -- Stability   : experimental -- Portability : Portable

@@ -10,7 +10,7 @@ -- | -- Module      : Error.Diagnose.Report.Internal -- Description : Internal workings for report definitions and pretty printing.--- Copyright   : (c) Mesabloo, 2021+-- Copyright   : (c) Mesabloo, 2021-2022 -- License     : BSD3 -- Stability   : experimental -- Portability : Portable@@ -38,9 +38,9 @@ import qualified Data.List.Safe as List import Data.Ord (Down (Down)) 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.Render.Terminal (AnsiStyle, Color (..), bold, color, colorDull)  -- | The type of diagnostic reports with abstract message type. data Report msg@@ -141,7 +141,7 @@   Int ->   -- | The whole report to output   Report msg ->-  Doc AnsiStyle+  Doc Annotation 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@@ -154,7 +154,7 @@        header =         annotate-          (bold <> color if isError then Red else Yellow)+          (KindColor isError)           ( lbracket               <> ( if isError                      then "error"@@ -189,7 +189,7 @@         <> {- (6) -} ( if null markers && null hints                          then mempty                          else-                           annotate (bold <> color Black) (pad (maxLineNumberLength + 2) (if withUnicode then '─' else '-') mempty <> if withUnicode then "╯" else "+")+                           annotate RuleColor (pad (maxLineNumberLength + 2) (if withUnicode then '─' else '-') mempty <> if withUnicode then "╯" else "+")                              <> hardline                      ) @@ -212,8 +212,8 @@   Int ->   -- | Whether to print with unicode characters or not.   Bool ->-  Doc AnsiStyle-dotPrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate (bold <> color Black) (if withUnicode then "•" else ":")+  Doc Annotation+dotPrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (if withUnicode then "•" else ":") {-# INLINE dotPrefix #-}  -- | Creates a "pipe"-prefix for a report line where there is no code.@@ -227,8 +227,8 @@   Int ->   -- | Whether to print with unicode characters or not.   Bool ->-  Doc AnsiStyle-pipePrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate (bold <> color Black) (if withUnicode then "│" else "|")+  Doc Annotation+pipePrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (if withUnicode then "│" else "|") {-# INLINE pipePrefix #-}  -- | Creates a line-prefix for a report line containing source code@@ -246,10 +246,10 @@   Int ->   -- | Whether to use unicode characters or not.   Bool ->-  Doc AnsiStyle+  Doc Annotation linePrefix leftLen lineNo withUnicode =   let lineNoLen = length (show lineNo)-   in annotate (bold <> color Black) $ mempty <+> pad (leftLen - lineNoLen) ' ' mempty <> pretty lineNo <+> if withUnicode then "│" else "|"+   in annotate RuleColor $ mempty <+> pad (leftLen - lineNoLen) ' ' mempty <> pretty lineNo <+> if withUnicode then "│" else "|" {-# INLINE linePrefix #-}  -- | Creates an ellipsis-prefix, when some line numbers are not consecutive.@@ -261,8 +261,8 @@ ellipsisPrefix ::   Int ->   Bool ->-  Doc AnsiStyle-ellipsisPrefix leftLen withUnicode = pad leftLen ' ' mempty <> annotate (bold <> color Black) (if withUnicode then space <> "⋮" else "...")+  Doc Annotation+ellipsisPrefix leftLen withUnicode = pad leftLen ' ' mempty <> annotate RuleColor (if withUnicode then space <> "⋮" else "...")  groupMarkersPerFile ::   Pretty msg =>@@ -304,7 +304,7 @@   Bool ->   -- | The list of line-ordered markers appearing in a single file   [(Position, Marker msg)] ->-  Doc AnsiStyle+  Doc Annotation prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength isFirst markers =   let (markersPerLine, multilineMarkers) = splitMarkersPerLine markers       -- split the list on whether markers are multiline or not@@ -320,13 +320,13 @@         ( if isFirst             then               space <> pad maxLineNumberLength ' ' mempty-                <+> annotate (bold <> color Black) (if withUnicode then "╭──▶" else "+-->")+                <+> annotate RuleColor (if withUnicode then "╭──▶" else "+-->")             else               space <> dotPrefix maxLineNumberLength withUnicode <> hardline-                <> annotate (bold <> color Black) (pad (maxLineNumberLength + 2) (if withUnicode then '─' else '-') mempty)-                <> annotate (bold <> color Black) (if withUnicode then "┼──▶" else "+-->")+                <> annotate RuleColor (pad (maxLineNumberLength + 2) (if withUnicode then '─' else '-') mempty)+                <> annotate RuleColor (if withUnicode then "┼──▶" else "+-->")         )-          <+> annotate (bold <> colorDull Green) reportFile+          <+> annotate FileColor reportFile    in {- (2) -} hardline <> fileMarker         <> hardline           <+> {- (3) -} pipePrefix maxLineNumberLength withUnicode@@ -357,7 +357,7 @@   [(Int, [(Position, Marker msg)])] ->   [(Position, Marker msg)] ->   [Int] ->-  Doc AnsiStyle+  Doc Annotation prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNumbers =   case lineNumbers of     [] ->@@ -427,19 +427,20 @@      showMultiline _ [] = mempty     showMultiline isLastMultiline multiline =-      let colorOfLastMultilineMarker = maybe mempty (markerColor isError . snd) (List.safeLast multiline)+      let colorOfLastMultilineMarker = markerColor isError . snd <$> List.safeLast multiline           -- take the color of the last multiline marker in case we need to add additional bars            prefix = hardline <+> dotPrefix leftLen withUnicode <> space-          prefixWithBar color = prefix <> annotate color (if withUnicode then "│ " else "| ") +          prefixWithBar color = prefix <> maybe id annotate color (if withUnicode then "│ " else "| ")+           showMultilineMarkerMessage (_, marker) isLast =             annotate (markerColor isError marker) $               ( if isLast && isLastMultiline                   then if withUnicode then "╰╸ " else "`- "                   else if withUnicode then "├╸ " else "|- "               )-                <> replaceLinesWith (if isLast then prefix <> "   " else prefixWithBar (markerColor isError marker) <> space) (pretty $ markerMessage marker)+                <> replaceLinesWith (if isLast then prefix <> "   " else prefixWithBar (Just $ markerColor isError marker) <> space) (pretty $ markerMessage marker)            showMultilineMarkerMessages [] = []           showMultilineMarkerMessages [m] = [showMultilineMarkerMessage m True]@@ -447,9 +448,9 @@        in prefixWithBar colorOfLastMultilineMarker <> prefix <> fold (List.intersperse prefix $ showMultilineMarkerMessages $ reverse multiline)  -- |-getLine_ :: HashMap FilePath [String] -> [(Position, Marker msg)] -> Int -> Int -> Bool -> (IntMap.HashMap Int Int, Doc AnsiStyle)+getLine_ :: HashMap FilePath [String] -> [(Position, Marker msg)] -> Int -> Int -> Bool -> (IntMap.HashMap Int Int, Doc Annotation) getLine_ files markers line tabSize isError = case List.safeIndex (line - 1) =<< (HashMap.!?) files . file . fst =<< List.safeHead markers of-  Nothing -> (mempty, annotate (bold <> colorDull Magenta) "<no line>")+  Nothing -> (mempty, annotate NoLineColor "<no line>")   Just code ->     let (tabs, code') = indexedWithTabsReplaced code      in ( tabs,@@ -462,7 +463,7 @@                       if bl == el                         then n >= bc && n < ec                         else (bl == line && n >= bc) || (el == line && n < ec) || (bl < line && el > line)-               in maybe id ((\m -> annotate (bold <> markerColor isError m)) . snd) (List.safeHead colorizingMarkers) (pretty c)+               in maybe id ((\m -> annotate (MarkerStyle $ markerColor isError m)) . snd) (List.safeHead colorizingMarkers) (pretty c)         )   where     indexedWithTabsReplaced :: String -> (IntMap.HashMap Int Int, [(Int, Char)])@@ -474,7 +475,7 @@     goIndexed n (x : xs) = bimap (IntMap.insert n (wcwidth x)) ((n, x) :) (goIndexed (n + 1) xs)  -- |-showAllMarkersInLine :: Pretty msg => Bool -> Bool -> (Doc AnsiStyle -> Doc AnsiStyle) -> Bool -> Bool -> Int -> IntMap.HashMap Int Int -> [(Position, Marker msg)] -> Doc AnsiStyle+showAllMarkersInLine :: Pretty msg => Bool -> Bool -> (Doc Annotation -> Doc Annotation) -> Bool -> Bool -> Int -> IntMap.HashMap Int Int -> [(Position, Marker msg)] -> Doc Annotation showAllMarkersInLine _ _ _ _ _ _ _ [] = mempty showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUnicode isError leftLen widths ms =   let maxMarkerColumn = snd $ end $ fst $ List.last $ List.sortOn (snd . end . fst) ms@@ -579,10 +580,10 @@   -- | The marker to extract the color from.   Marker msg ->   -- | A function used to color a 'Doc'.-  AnsiStyle-markerColor isError (This _) = if isError then color Red else color Yellow-markerColor _ (Where _) = colorDull Blue-markerColor _ (Maybe _) = color Magenta+  Annotation+markerColor isError (This _) = ThisColor isError+markerColor _ (Where _) = WhereColor+markerColor _ (Maybe _) = MaybeColor {-# INLINE markerColor #-}  -- | Retrieves the message held by a marker.@@ -593,7 +594,7 @@ {-# INLINE markerMessage #-}  -- | Pretty prints all hints.-prettyAllHints :: Pretty msg => [msg] -> Int -> Bool -> Doc AnsiStyle+prettyAllHints :: Pretty msg => [msg] -> Int -> Bool -> Doc Annotation prettyAllHints [] _ _ = mempty prettyAllHints (h : hs) leftLen withUnicode =   {-@@ -601,5 +602,5 @@         (1)         : Hint: <hint message>   -}   let prefix = hardline <+> pipePrefix leftLen withUnicode-   in prefix <+> annotate (color Cyan) (annotate bold "Hint:" <+> replaceLinesWith (prefix <+> "      ") (pretty h))+   in prefix <+> annotate HintColor ("Hint:" <+> replaceLinesWith (prefix <+> "      ") (pretty h))         <> prettyAllHints hs leftLen withUnicode

@@ -0,0 +1,102 @@+-- |+-- Module      : Error.Diagnose.Style+-- Description : Custom style definitions+-- Copyright   : (c) Mesabloo, 2021-2022+-- License     : BSD3+-- Stability   : experimental+-- Portability : Portable+module Error.Diagnose.Style+  ( -- * Defining new style+    Annotation (..),+    Style,+    -- $defining_new_styles++    -- * Default style specification+    defaultStyle,++    -- * Re-exports+    reAnnotate,+  )+where++import Prettyprinter (Doc, reAnnotate)+import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), bold, color, colorDull)++-- $defining_new_styles+--+-- Defining new color styles (one may call them "themes") is actually rather easy.+--+-- A 'Style' is a function from an annotated 'Doc'ument to another annotated 'Doc'ument.+-- Note that only the annotation type changes, hence the need of only providing a unidirectional mapping between those.+--+-- 'Annotation's are used when creating a 'Doc'ument and are simply placeholders to specify custom colors.+-- 'AnsiStyle' is the concrete annotation to specify custom colors when rendering a 'Doc'ument.+--+-- One may define additional styles as follows:+--+-- > myNewCustomStyle :: Style+-- > myNewCustomStyle = reAnnotate \case+-- >   -- all cases for all annotations+--+-- For simplicity's sake, a default style is given as 'defaultStyle'.++-- | Some annotations as placeholders for colors in a 'Doc'.+data Annotation+  = -- | The color of 'Error.Diagnose.Report.This' markers, depending on whether the report is an error+    --   report or a warning report.+    ThisColor+      Bool+  | -- | The color of 'Error.Diagnose.Report.Maybe' markers.+    MaybeColor+  | -- | The color of 'Error.Diagnose.Report.Where' markers.+    WhereColor+  | -- | The color for hints.+    --+    --   Note that the beginning @Hint:@ text will always be in bold.+    HintColor+  | -- | The color for file names.+    FileColor+  | -- | The color of the rule separating the code/markers from the line numbers.+    RuleColor+  | -- | The color of the @[error]@/@[warning]@ at the top, depending on whether+    --   this is an error or warning report.+    KindColor+      Bool+  | -- | The color in which to output the @<no line>@ information when the file was not found.+    NoLineColor+  | -- | Additional style to apply to marker rules (e.g. bold) on top of some+    --   already processed color annotation.+    MarkerStyle+      Annotation++-- | 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++-------------------------------------------++-- | The default style for diagnostics, where:+--+--   * 'Error.Diagnose.Report.This' markers are colored in red for errors and yellow for warnings+--   * 'Error.Diagnose.Report.Where' markers are colored in dull blue+--   * 'Error.Diagnose.Report.Maybe' markers are colored in magenta+--   * Marker rules are of the same color of the marker, but also in bold+--   * Hints are output in cyan+--   * The left rules are colored in bold black+--   * File names are output in dull green+--   * The @[error]@/@[warning]@ at the top is colored in red for errors and yellow for warnings+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 -> bold <> style st

@@ -0,0 +1,11 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Instances where++import Data.Void (Void)+import Error.Diagnose+import Error.Diagnose.Compat.Megaparsec++instance HasHints Void msg where+  hints _ = mempty

@@ -0,0 +1,55 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS -Wno-orphans #-}++module Repro6 where++import Data.Bifunctor (first)+import Data.Char (isAlpha)+import Data.Text (Text)+import qualified Data.Text as Text (unpack)+import Data.Void (Void)+import Error.Diagnose+import Error.Diagnose.Compat.Megaparsec+import Instances ()+import qualified Text.Megaparsec as MP+import qualified Text.Megaparsec.Char as MP+import qualified Text.Megaparsec.Char.Lexer as MP++main :: IO ()+main = do+  let filename :: FilePath = "<interactive>"+      content1 :: Text = "0000000123456"+      content2 :: Text = "00000a2223266"+      content3 :: Text = "aaa\naab\naba\na\nb\n"++  let res1 = first (errorDiagnosticFromBundle Nothing "Parse error on input" Nothing) $ MP.runParser @Void (MP.some MP.decimal <* MP.eof) filename content1+      res2 = first (errorDiagnosticFromBundle Nothing "Parse error on input" Nothing) $ MP.runParser @Void (MP.some MP.decimal <* MP.eof) filename content2+      res3 =+        first (errorDiagnosticFromBundle Nothing "Parse error on input" Nothing) $+          let a = MP.char 'a'+              errSkip e = do+                MP.registerParseError e+                _ <- MP.takeWhileP Nothing isAlpha <* MP.eol+                return ""+           in MP.runParser @Void+                (MP.many (MP.withRecovery errSkip (MP.some a <* MP.eol)) <* MP.eof)+                filename+                content3++  case res1 of+    Left diag -> printDiagnostic stdout True True 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)+    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)+    Right res -> print res

@@ -13,13 +13,12 @@ import Data.Void (Void) import Error.Diagnose 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 -instance HasHints Void msg where-  hints _ = mempty- main :: IO () main = do   let filename :: FilePath = "<interactive>"@@ -30,8 +29,12 @@       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 (addFile diag filename (Text.unpack content1) :: Diagnostic String)+    Left diag -> printDiagnostic stdout True True 4 defaultStyle (addFile diag filename (Text.unpack content1) :: Diagnostic String)     Right res -> print res   case res2 of-    Left diag -> printDiagnostic stdout True True 4 (addFile diag filename (Text.unpack content2) :: Diagnostic String)+    Left diag -> printDiagnostic stdout True True 4 defaultStyle (addFile diag filename (Text.unpack content2) :: Diagnostic String)     Right res -> print res++  putStrLn "---------------------------------------------------"++  Repro6.main

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

@@ -30,10 +30,10 @@       res2 = first (errorDiagnosticFromParseError Nothing "Parse error on input" Nothing) $ P.parse (P.many1 P.digit <* P.eof) filename content2    case res1 of-    Left diag -> printDiagnostic stdout True True 4 (addFile diag filename (Text.unpack content1) :: Diagnostic String)+    Left diag -> printDiagnostic stdout True True 4 defaultStyle (addFile diag filename (Text.unpack content1) :: Diagnostic String)     Right res -> print res   case res2 of-    Left diag -> printDiagnostic stdout True True 4 (addFile diag filename (Text.unpack content2) :: Diagnostic String)+    Left diag -> printDiagnostic stdout True True 4 defaultStyle (addFile diag filename (Text.unpack content2) :: Diagnostic String)     Right res -> print res    -- all issue reproduction

@@ -13,6 +13,7 @@     addFile,     addReport,     def,+    defaultStyle, #ifdef USE_AESON     diagnosticToJson, #endif@@ -73,12 +74,12 @@           beautifulExample         ] -  let diag = HashMap.foldlWithKey' addFile (foldr (flip addReport) def reports) files+  let diag = HashMap.foldlWithKey' addFile (foldl addReport def reports) files    hPutStrLn stdout "\n\nWith unicode: ─────────────────────────\n"-  printDiagnostic stdout True True 4 diag+  printDiagnostic stdout True True 4 defaultStyle diag   hPutStrLn stdout "\n\nWithout unicode: ----------------------\n"-  printDiagnostic stdout False True 4 diag+  printDiagnostic stdout False True 4 defaultStyle diag #ifdef USE_AESON   hPutStrLn stdout "\n\nAs JSON: ------------------------------\n"   BS.hPutStr stdout (diagnosticToJson diag)