diff --git a/README.md b/README.md index 1edbab8..71379b4 100644 --- a/README.md +++ b/README.md @@ -102,8 +102,8 @@ let beautifulExample = let diagnostic = addFile def "somefile.zc" "let id(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). diff --git a/diagnose.cabal b/diagnose.cabal index 7637b74..38531f8 100644 --- a/diagnose.cabal +++ b/diagnose.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: diagnose -version: 2.4.0 +version: 2.5.0 synopsis: Beautiful error reporting done easily description: This package provides a simple way of getting beautiful compiler/interpreter errors using a very simple interface for the programmer. diff --git a/src/Error/Diagnose.hs b/src/Error/Diagnose.hs index 0f7a641..de42b80 100644 --- a/src/Error/Diagnose.hs +++ b/src/Error/Diagnose.hs @@ -241,7 +241,7 @@ import Error.Diagnose.Style as Export -- > -- Creates a new diagnostic with no default hints from the bundle returned by megaparsec -- > diag' = addFile diag filename content -- > -- Add the file used when parsing with the same filename given to 'MP.runParser' --- > in printDiagnostic stderr True True 4 diag' +-- > in printDiagnostic stderr True 4 diag' -- > Right res -> print res -- -- This example will return the following error message (assuming default instances for @'Error.Diagnose.Compat.Megaparsec.HasHints' 'Data.Void.Void' msg@): @@ -282,7 +282,7 @@ import Error.Diagnose.Style as Export -- > -- Creates a new diagnostic with no default hints from the bundle returned by megaparsec -- > diag' = addFile diag filename content -- > -- Add the file used when parsing with the same filename given to 'MP.runParser' --- > in printDiagnostic stderr True True 4 diag' +-- > in printDiagnostic stderr True 4 diag' -- > Right res -> print res -- -- This will output the following error on @stderr@: diff --git a/src/Error/Diagnose/Diagnostic.hs b/src/Error/Diagnose/Diagnostic.hs index fcc9e04..c2f5a81 100644 --- a/src/Error/Diagnose/Diagnostic.hs +++ b/src/Error/Diagnose/Diagnostic.hs @@ -25,7 +25,11 @@ import Error.Diagnose.Diagnostic.Internal as Export hasReports, reportsOf, prettyDiagnostic, + prettyDiagnostic', printDiagnostic, + printDiagnostic', warningsToErrors, + WithUnicode(..), + TabSize(..), ) import System.IO as Export (stderr, stdout) diff --git a/src/Error/Diagnose/Diagnostic/Internal.hs b/src/Error/Diagnose/Diagnostic/Internal.hs index 7e59379..605bbe2 100644 --- a/src/Error/Diagnose/Diagnostic/Internal.hs +++ b/src/Error/Diagnose/Diagnostic/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} -- | @@ -13,7 +14,7 @@ -- It is also highly undocumented. -- -- Please limit yourself to the "Error.Diagnose.Diagnostic" module, which exports some of the useful functions defined here. -module Error.Diagnose.Diagnostic.Internal (module Error.Diagnose.Diagnostic.Internal, def) where +module Error.Diagnose.Diagnostic.Internal (module Error.Diagnose.Diagnostic.Internal, def, WithUnicode(..), TabSize(..)) where import Control.Monad.IO.Class (MonadIO, liftIO) #ifdef USE_AESON @@ -29,10 +30,10 @@ import Data.Foldable (fold, toList) import qualified Data.HashMap.Lazy as HashMap import Data.List (intersperse) import Error.Diagnose.Report (Report) -import Error.Diagnose.Report.Internal (FileMap, errorToWarning, prettyReport, warningToError) +import Error.Diagnose.Report.Internal (FileMap, errorToWarning, prettyReport, warningToError, WithUnicode(..), TabSize(..)) import Error.Diagnose.Style (Annotation, Style) -import Prettyprinter (Doc, Pretty, hardline, unAnnotate) -import Prettyprinter.Render.Terminal (hPutDoc) +import Prettyprinter (Doc, Pretty, hardline, pretty, defaultLayoutOptions, reAnnotateS, layoutPretty) +import Prettyprinter.Render.Terminal (renderIO) import System.IO (Handle) -- | The data type for diagnostic containing messages of an abstract type. @@ -47,6 +48,7 @@ data Diagnostic msg -- Reports are output one by one, without connections in between. !FileMap -- ^ A map associating files with their content as lists of lines. + deriving (Functor, Foldable, Traversable) instance Default (Diagnostic msg) where def = Diagnostic mempty mempty @@ -98,36 +100,70 @@ errorsToWarnings (Diagnostic reports files) = Diagnostic (errorToWarning <$> rep prettyDiagnostic :: Pretty msg => -- | Should we use unicode when printing paths? - Bool -> + WithUnicode -> -- | The number of spaces each TAB character will span. - Int -> + TabSize -> -- | The diagnostic to print. Diagnostic msg -> - Doc Annotation -prettyDiagnostic withUnicode tabSize (Diagnostic reports file) = - fold . intersperse hardline $ prettyReport file withUnicode tabSize <$> toList reports + Doc (Annotation ann) +prettyDiagnostic withUnicode tabSize = + prettyDiagnostic' withUnicode tabSize . fmap pretty {-# INLINE prettyDiagnostic #-} +-- | Like 'prettyDiagnostic' except that instead of requiring a 'pretty' +-- instance for messages, this allows passing in your own 'Doc'. Custom +-- annotations are retained in 'OtherStyle' +prettyDiagnostic' :: + -- | Should we use unicode when printing paths? + WithUnicode -> + -- | The number of spaces each TAB character will span. + TabSize -> + -- | The diagnostic to print. + Diagnostic (Doc ann) -> + Doc (Annotation ann) +prettyDiagnostic' withUnicode tabSize (Diagnostic reports file) = + fold . intersperse hardline $ prettyReport file withUnicode tabSize <$> toList reports + -- | Prints a 'Diagnostic' onto a specific 'Handle'. printDiagnostic :: (MonadIO m, Pretty msg) => -- | The handle onto which to output the diagnostic. Handle -> -- | Should we print with unicode characters? - Bool -> - -- | 'False' to disable colors. - Bool -> + WithUnicode -> -- | The number of spaces each TAB character will span. - Int -> + TabSize -> -- | The style in which to output the diagnostic. - Style -> + Style ann -> -- | The diagnostic to output. Diagnostic msg -> m () -printDiagnostic handle withUnicode withColors tabSize style diag = - liftIO $ hPutDoc handle ((if withColors then style else unAnnotate) $ prettyDiagnostic withUnicode tabSize diag) +printDiagnostic handle withUnicode tabSize style = + printDiagnostic' handle withUnicode tabSize style . fmap pretty {-# INLINE printDiagnostic #-} +-- | Like 'printDiagnostic' except that instead of requiring a 'pretty' +-- instance for messages, this allows passing in your own 'Doc'. +printDiagnostic' :: + MonadIO m => + -- | The handle onto which to output the diagnostic. + Handle -> + -- | Should we print with unicode characters? + WithUnicode -> + -- | The number of spaces each TAB character will span. + TabSize -> + -- | The style in which to output the diagnostic. + Style ann -> + -- | The diagnostic to output. + Diagnostic (Doc ann) -> + m () +printDiagnostic' handle withUnicode tabSize style = + liftIO + . renderIO handle + . reAnnotateS style + . layoutPretty defaultLayoutOptions + . prettyDiagnostic' withUnicode tabSize + -- | Inserts a new referenceable file within the diagnostic. addFile :: Diagnostic msg -> diff --git a/src/Error/Diagnose/Pretty.hs b/src/Error/Diagnose/Pretty.hs index dc904f4..90e47c0 100644 --- a/src/Error/Diagnose/Pretty.hs +++ b/src/Error/Diagnose/Pretty.hs @@ -1,4 +1,3 @@ module Error.Diagnose.Pretty (module Export) where import qualified Prettyprinter as Export -import qualified Prettyprinter.Render.Terminal as Export diff --git a/src/Error/Diagnose/Report/Internal.hs b/src/Error/Diagnose/Report/Internal.hs index 9a9014e..fba4907 100644 --- a/src/Error/Diagnose/Report/Internal.hs +++ b/src/Error/Diagnose/Report/Internal.hs @@ -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 @@ -478,7 +482,7 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu (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 @@ -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: -} - 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 diff --git a/src/Error/Diagnose/Style.hs b/src/Error/Diagnose/Style.hs index 46ee9f7..45c67d0 100644 --- a/src/Error/Diagnose/Style.hs +++ b/src/Error/Diagnose/Style.hs @@ -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 - 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 diff --git a/test/megaparsec/Repro6.hs b/test/megaparsec/Repro6.hs index d906d6f..51e1fa3 100644 --- a/test/megaparsec/Repro6.hs +++ b/test/megaparsec/Repro6.hs @@ -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 diff --git a/test/megaparsec/Spec.hs b/test/megaparsec/Spec.hs index 3fa757f..e07ceb1 100644 --- a/test/megaparsec/Spec.hs +++ b/test/megaparsec/Spec.hs @@ -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 "---------------------------------------------------" diff --git a/test/parsec/Repro2.hs b/test/parsec/Repro2.hs index b2c8d38..a71f698 100644 --- a/test/parsec/Repro2.hs +++ b/test/parsec/Repro2.hs @@ -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 diff --git a/test/parsec/Spec.hs b/test/parsec/Spec.hs index 8983380..13ca6fd 100644 --- a/test/parsec/Spec.hs +++ b/test/parsec/Spec.hs @@ -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 diff --git a/test/rendering/Spec.hs b/test/rendering/Spec.hs index 1193ee9..d3a097d 100644 --- a/test/rendering/Spec.hs +++ b/test/rendering/Spec.hs @@ -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 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 = Err