Merge pull request #21 from expipiplus1/doc-message

Add functionality to render diagnostics with user provided Docs
This commit is contained in:
Mesabloo 2023-06-02 21:01:02 +02:00 committed by GitHub
commit 26266751bc
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
13 changed files with 330 additions and 158 deletions

View File

@ -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).

View File

@ -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.

View File

@ -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@:

View File

@ -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)

View File

@ -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 ->

View File

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

View File

@ -1,5 +1,6 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
@ -23,6 +24,8 @@
module Error.Diagnose.Report.Internal
( module Error.Diagnose.Report.Internal
, Report(.., Warn, Err)
, WithUnicode(..)
, TabSize(..)
) where
#ifdef USE_AESON
@ -47,8 +50,9 @@ import Data.String (IsString (fromString))
import qualified Data.Text as Text
import Error.Diagnose.Position
import Error.Diagnose.Style (Annotation (..))
import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>))
import Prettyprinter.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 +71,7 @@ data Report msg
-- ^ A map associating positions with marker to show under the source code.
[Note msg]
-- ^ A list of notes to add at the end of the report.
deriving (Functor, Foldable, Traversable)
-- | Pattern synonym for a warning report.
pattern Warn :: Maybe msg -> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
@ -120,6 +125,7 @@ data Marker msg
Maybe msg
| -- | An empty marker, whose sole purpose is to include a line of code in the report without markers under.
Blank
deriving (Functor, Foldable, Traversable)
instance Eq (Marker msg) where
This _ == This _ = True
@ -147,6 +153,7 @@ data Note msg
Note msg
| -- | A hint, to propose potential fixes or help towards fixing the issue.
Hint msg
deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
#ifdef USE_AESON
instance ToJSON msg => ToJSON (Note msg) where
@ -187,18 +194,21 @@ errorToWarning :: Report msg -> Report msg
errorToWarning (Report True code msg markers notes) = Report False code msg markers notes
errorToWarning r@(Report False _ _ _ _) = r
data WithUnicode = WithoutUnicode | WithUnicode
newtype TabSize = TabSize Int
-- | Pretty prints a report to a 'Doc' handling colors.
prettyReport ::
Pretty msg =>
-- | The content of the file the reports are for
FileMap ->
-- | Should we print paths in unicode?
Bool ->
WithUnicode ->
-- | The number of spaces each TAB character will span
Int ->
TabSize ->
-- | The whole report to output
Report msg ->
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 +229,7 @@ prettyReport fileContent withUnicode tabSize (Report isError code message marker
)
<> case code of
Nothing -> rbracket
Just code -> space <> pretty code <> rbracket
Just code -> space <> annotated code <> rbracket
)
in {-
A report is of the form:
@ -234,7 +244,7 @@ prettyReport fileContent withUnicode tabSize (Report isError code message marker
(6) -------+
-}
{- (1) -} header <> colon <+> align (pretty message)
{- (1) -} header <> colon <+> align (annotated message)
<> {- (2), (3), (4) -} fold (uncurry (prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength) <$> groupedMarkers)
<> {- (5) -} ( if
| null hints && null markers -> mempty
@ -246,7 +256,7 @@ prettyReport fileContent withUnicode tabSize (Report isError code message marker
<> {- (6) -} ( if null markers && null hints
then mempty
else
annotate RuleColor (pad (maxLineNumberLength + 2) (if withUnicode then '─' else '-') mempty <> if withUnicode then "" else "+")
annotate RuleColor (pad (maxLineNumberLength + 2) (unicode '-' '─' withUnicode) mempty <> unicode "+" "" withUnicode)
<> hardline
)
@ -268,9 +278,11 @@ dotPrefix ::
-- | The length of the left space before the bullet.
Int ->
-- | Whether to print with unicode characters or not.
Bool ->
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 +295,9 @@ pipePrefix ::
-- | 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 +314,11 @@ linePrefix ::
-- | 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 +329,11 @@ linePrefix leftLen lineNo withUnicode =
-- [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,22 +357,21 @@ groupMarkersPerFile markers =
-- | Prettyprint a sub-report, which is a part of the report spanning across a single file
prettySubReport ::
Pretty msg =>
-- | The content of files in the diagnostics
FileMap ->
-- | Is the output done with Unicode characters?
Bool ->
WithUnicode ->
-- | Is the current report an error report?
Bool ->
-- | The number of spaces each TAB character will span
Int ->
TabSize ->
-- | The size of the biggest line number
Int ->
-- | Is this sub-report the first one in the list?
Bool ->
-- | The list of line-ordered markers appearing in a single file
[(Position, Marker msg)] ->
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
@ -377,16 +387,16 @@ prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength isFi
( if isFirst
then
space <> pad maxLineNumberLength ' ' mempty
<+> annotate RuleColor (if withUnicode then "╭──▶" else "+-->")
<+> annotate RuleColor (unicode "+-->" "╭──▶" withUnicode)
else
space <> dotPrefix maxLineNumberLength withUnicode <> hardline
<> annotate RuleColor (pad (maxLineNumberLength + 2) (if withUnicode then '─' else '-') mempty)
<> annotate RuleColor (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 +414,16 @@ splitMarkersPerLine (m@(Position {..}, _) : ms) =
-- |
prettyAllLines ::
Pretty msg =>
FileMap ->
Bool ->
WithUnicode ->
Bool ->
-- | The number of spaces each TAB character will span
TabSize ->
Int ->
Int ->
[(Int, [(Position, Marker 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
[] ->
@ -456,19 +465,14 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu
if not $ null multiline
then
if not $ null allMultilineMarkersSpanningLine
then colorOfFirstMultilineMarker if withUnicode then "" else "| "
then colorOfFirstMultilineMarker (unicode "| " "" withUnicode)
else " "
else mempty
(p@(Position _ (el, _) _), marker) : _ ->
let hasPredecessor = el == line || maybe False ((/=) p . fst . fst) (List.safeUncons multiline)
in colorOfFirstMultilineMarker
( if
| 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
@ -489,33 +493,33 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu
let colorOfFirstMultilineMarker = markerColor isError . snd <$> List.safeHead multiline
-- take the color of the last multiline marker in case we need to add additional bars
prefix = hardline <+> dotPrefix leftLen withUnicode <> space
prefix = space <> dotPrefix leftLen withUnicode <> space
prefixWithBar color = prefix <> maybe id annotate color (if withUnicode then "" else "| ")
prefixWithBar color = prefix <> maybe id annotate color (unicode "| " "" withUnicode)
showMultilineMarkerMessage (_, Blank) _ = mempty
showMultilineMarkerMessage (_, marker) isLast =
annotate (markerColor isError marker) $
( if isLast && isLastMultiline
then if withUnicode then "╰╸ " else "`- "
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 +552,12 @@ getLine_ files markers line tabSize isError =
mkWidthTable s = listArray (1, length s) (ifTab tabSize wcwidth <$> s)
-- |
showAllMarkersInLine :: Pretty msg => Bool -> Bool -> (Doc Annotation -> Doc Annotation) -> Bool -> Bool -> Int -> WidthTable -> [(Position, Marker msg)] -> Doc Annotation
showAllMarkersInLine :: Bool -> Bool -> (Doc (Annotation ann) -> Doc (Annotation ann)) -> WithUnicode -> Bool -> Int -> WidthTable -> [(Position, Marker (Doc ann))] -> Doc (Annotation ann)
showAllMarkersInLine _ _ _ _ _ _ _ [] = mempty
showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUnicode isError leftLen widths ms =
let maxMarkerColumn = snd $ end $ fst $ List.last $ List.sortOn (snd . end . fst) ms
specialPrefix
| inSpanOfMultiline = colorMultilinePrefix (if withUnicode then "" else "| ") <> space
| inSpanOfMultiline = colorMultilinePrefix (unicode "| " "" withUnicode) <> space
| hasMultilines = colorMultilinePrefix " " <> space
| otherwise = mempty
in -- get the maximum end column, so that we know when to stop looking for other markers on the same line
@ -574,8 +578,8 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn
annotate
(markerColor isError marker)
( if snd begin == n
then (if withUnicode then "" else "^") <> fold (replicate (widthAt n - 1) if withUnicode then "" else "-")
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
@ -606,7 +610,7 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn
let (pipesBefore, pipesAfter) = List.partition ((< bc) . snd . begin . fst) nubbedPipes
-- split the list so that all pipes before can have `|`s but pipes after won't
pipesBeforeRendered = pipesBefore <&> second \marker -> annotate (markerColor isError marker) (if withUnicode then "" else "|")
pipesBeforeRendered = pipesBefore <&> second \marker -> annotate (markerColor isError marker) (unicode "|" "" withUnicode)
-- pre-render pipes which are before because they will be shown
lastBeginPosition = snd . begin . fst <$> List.safeLast (List.sortOn (snd . begin . fst) pipesAfter)
@ -615,49 +619,56 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn
Nothing -> 0
Just col -> widthsBetween bc col
currentPipe =
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 +678,7 @@ markerColor ::
-- | The marker to extract the color from.
Marker msg ->
-- | A function used to color a 'Doc'.
Annotation
Annotation ann
markerColor isError (This _) = ThisColor isError
markerColor _ (Where _) = WhereColor
markerColor _ (Maybe _) = MaybeColor
@ -683,15 +694,15 @@ markerMessage Blank = undefined
{-# INLINE markerMessage #-}
-- | Pretty prints all hints.
prettyAllHints :: Pretty msg => [Note msg] -> Int -> Bool -> Doc Annotation
prettyAllHints :: [Note (Doc ann)] -> Int -> WithUnicode -> Doc (Annotation ann)
prettyAllHints [] _ _ = mempty
prettyAllHints (h : hs) leftLen withUnicode =
{-
A hint is composed of:
(1) : Hint: <hint message>
-}
let prefix = hardline <+> pipePrefix leftLen withUnicode
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 +715,11 @@ safeArrayIndex :: (Ix i, IArray a e) => i -> a i e -> Maybe e
safeArrayIndex i a
| Array.inRange (Array.bounds a) i = Just (a ! i)
| otherwise = Nothing
annotated :: Doc ann -> Doc (Annotation ann)
annotated = reAnnotate OtherStyle
unicode :: a -> a -> WithUnicode -> a
unicode f t = \case
WithoutUnicode -> f
WithUnicode -> t

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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