From d06f4c18100e5a6adab174512a5f78c5f988b647 Mon Sep 17 00:00:00 2001 From: Ellie Hermaszewska Date: Tue, 16 May 2023 11:03:23 +0800 Subject: [PATCH 01/16] Functor, Foldable, Traversable instances for Report, Marker and Note --- src/Error/Diagnose/Diagnostic/Internal.hs | 4 ++++ src/Error/Diagnose/Report/Internal.hs | 6 ++++++ 2 files changed, 10 insertions(+) diff --git a/src/Error/Diagnose/Diagnostic/Internal.hs b/src/Error/Diagnose/Diagnostic/Internal.hs index 7e59379..bd01831 100644 --- a/src/Error/Diagnose/Diagnostic/Internal.hs +++ b/src/Error/Diagnose/Diagnostic/Internal.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} -- | @@ -47,6 +50,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 diff --git a/src/Error/Diagnose/Report/Internal.hs b/src/Error/Diagnose/Report/Internal.hs index 9a9014e..4c42ead 100644 --- a/src/Error/Diagnose/Report/Internal.hs +++ b/src/Error/Diagnose/Report/Internal.hs @@ -1,5 +1,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} @@ -67,6 +70,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 +124,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 +152,7 @@ data Note msg Note msg | -- | A hint, to propose potential fixes or help towards fixing the issue. Hint msg + deriving (Functor, Foldable, Traversable) #ifdef USE_AESON instance ToJSON msg => ToJSON (Note msg) where From 4270c6e320439ef36be1c0789047734fccda7ba2 Mon Sep 17 00:00:00 2001 From: Ellie Hermaszewska Date: Tue, 16 May 2023 11:11:32 +0800 Subject: [PATCH 02/16] add functionality for Doc messages --- src/Error/Diagnose/Diagnostic/Internal.hs | 45 +++++++-- src/Error/Diagnose/Report/Internal.hs | 112 +++++++++++----------- src/Error/Diagnose/Style.hs | 38 ++++---- 3 files changed, 112 insertions(+), 83 deletions(-) diff --git a/src/Error/Diagnose/Diagnostic/Internal.hs b/src/Error/Diagnose/Diagnostic/Internal.hs index bd01831..99af858 100644 --- a/src/Error/Diagnose/Diagnostic/Internal.hs +++ b/src/Error/Diagnose/Diagnostic/Internal.hs @@ -34,8 +34,8 @@ import Data.List (intersperse) import Error.Diagnose.Report (Report) import Error.Diagnose.Report.Internal (FileMap, errorToWarning, prettyReport, warningToError) import Error.Diagnose.Style (Annotation, Style) -import Prettyprinter (Doc, Pretty, hardline, unAnnotate) -import Prettyprinter.Render.Terminal (hPutDoc) +import Prettyprinter (Doc, Pretty, hardline, unAnnotate, pretty) +import Prettyprinter.Render.Terminal (hPutDoc, AnsiStyle) import System.IO (Handle) -- | The data type for diagnostic containing messages of an abstract type. @@ -108,10 +108,25 @@ prettyDiagnostic :: -- | The diagnostic to print. Diagnostic msg -> Doc Annotation -prettyDiagnostic withUnicode tabSize (Diagnostic reports file) = - fold . intersperse hardline $ prettyReport file withUnicode tabSize <$> toList reports +prettyDiagnostic withUnicode tabSize = + prettyDiagnostic' id withUnicode tabSize . fmap pretty {-# INLINE prettyDiagnostic #-} +-- | Like 'prettyDiagnostic', but instead of requiring a 'Pretty' instance for +-- diagnostic messages this allows you to provide your own 'Doc's +prettyDiagnostic' :: + -- | How to reannotate Diagnose's output + (Annotation -> ann) -> + -- | Should we use unicode when printing paths? + Bool -> + -- | The number of spaces each TAB character will span. + Int -> + -- | The diagnostic to print. + Diagnostic (Doc ann) -> + Doc ann +prettyDiagnostic' sty withUnicode tabSize (Diagnostic reports file) = + fold . intersperse hardline $ prettyReport sty file withUnicode tabSize <$> toList reports + -- | Prints a 'Diagnostic' onto a specific 'Handle'. printDiagnostic :: (MonadIO m, Pretty msg) => @@ -128,10 +143,28 @@ printDiagnostic :: -- | 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 withColors tabSize style = + printDiagnostic' handle withUnicode tabSize (if withColors then style else const mempty) . fmap pretty {-# INLINE printDiagnostic #-} +-- | Like 'printDiagnostic', but instead of requiring a 'Pretty' instance for +-- diagnostic messages this allows you to provide your own 'Doc's +printDiagnostic' :: + (MonadIO m) => + -- | The handle onto which to output the diagnostic. + Handle -> + -- | Should we print with unicode characters? + Bool -> + -- | The number of spaces each TAB character will span. + Int -> + -- | How to reannotate Diagnose's output + (Annotation -> AnsiStyle) -> + -- | The diagnostic to output. + Diagnostic (Doc AnsiStyle) -> + m () +printDiagnostic' handle withUnicode tabSize sty diag = + liftIO $ hPutDoc handle (prettyDiagnostic' sty withUnicode tabSize diag) + -- | Inserts a new referenceable file within the diagnostic. addFile :: Diagnostic msg -> diff --git a/src/Error/Diagnose/Report/Internal.hs b/src/Error/Diagnose/Report/Internal.hs index 4c42ead..fa2d845 100644 --- a/src/Error/Diagnose/Report/Internal.hs +++ b/src/Error/Diagnose/Report/Internal.hs @@ -50,7 +50,7 @@ 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 (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>), reAnnotate) import Prettyprinter.Internal (Doc (..)) type FileMap = HashMap FilePath (Array Int String) @@ -195,7 +195,8 @@ errorToWarning r@(Report False _ _ _ _) = r -- | Pretty prints a report to a 'Doc' handling colors. prettyReport :: - Pretty msg => + -- | How to reannotate Diagnose's output + (Annotation -> ann) -> -- | The content of the file the reports are for FileMap -> -- | Should we print paths in unicode? @@ -203,9 +204,9 @@ prettyReport :: -- | The number of spaces each TAB character will span Int -> -- | The whole report to output - Report msg -> - Doc Annotation -prettyReport fileContent withUnicode tabSize (Report isError code message markers hints) = + Report (Doc ann) -> + Doc ann +prettyReport sty 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 @@ -217,7 +218,7 @@ prettyReport fileContent withUnicode tabSize (Report isError code message marker header = annotate - (KindColor isError) + (sty (KindColor isError)) ( lbracket <> ( if isError then "error" @@ -225,7 +226,7 @@ prettyReport fileContent withUnicode tabSize (Report isError code message marker ) <> case code of Nothing -> rbracket - Just code -> space <> pretty code <> rbracket + Just code -> space <> code <> rbracket ) in {- A report is of the form: @@ -240,19 +241,19 @@ prettyReport fileContent withUnicode tabSize (Report isError code message marker (6) -------+ -} - {- (1) -} header <> colon <+> align (pretty message) - <> {- (2), (3), (4) -} fold (uncurry (prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength) <$> groupedMarkers) + {- (1) -} header <> colon <+> align message + <> {- (2), (3), (4) -} foldMap (uncurry (prettySubReport sty fileContent withUnicode isError tabSize maxLineNumberLength)) groupedMarkers <> {- (5) -} ( if | null hints && null markers -> mempty | null hints -> mempty - | otherwise -> hardline <+> dotPrefix maxLineNumberLength withUnicode + | otherwise -> hardline <+> reAnnotate sty (dotPrefix maxLineNumberLength withUnicode) ) - <> prettyAllHints hints maxLineNumberLength withUnicode + <> prettyAllHints sty hints maxLineNumberLength withUnicode <> hardline <> {- (6) -} ( if null markers && null hints then mempty else - annotate RuleColor (pad (maxLineNumberLength + 2) (if withUnicode then '─' else '-') mempty <> if withUnicode then "╯" else "+") + annotate (sty RuleColor) (pad (maxLineNumberLength + 2) (if withUnicode then '─' else '-') mempty <> if withUnicode then "╯" else "+") <> hardline ) @@ -328,7 +329,6 @@ ellipsisPrefix :: ellipsisPrefix leftLen withUnicode = pad leftLen ' ' mempty <> annotate RuleColor (if withUnicode then space <> "⋮" else "...") groupMarkersPerFile :: - Pretty msg => [(Position, Marker msg)] -> [(Bool, [(Position, Marker msg)])] groupMarkersPerFile [] = [] @@ -352,7 +352,8 @@ groupMarkersPerFile markers = -- | Prettyprint a sub-report, which is a part of the report spanning across a single file prettySubReport :: - Pretty msg => + -- | How to reannotate Diagnose's output + (Annotation -> ann) -> -- | The content of files in the diagnostics FileMap -> -- | Is the output done with Unicode characters? @@ -366,9 +367,9 @@ prettySubReport :: -- | 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 -prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength isFirst markers = + [(Position, Marker (Doc ann))] -> + Doc ann +prettySubReport sty fileContent withUnicode isError tabSize maxLineNumberLength isFirst markers = let (markersPerLine, multilineMarkers) = splitMarkersPerLine markers -- split the list on whether markers are multiline or not @@ -390,10 +391,10 @@ prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength isFi <> annotate RuleColor (if withUnicode then "┼──▶" else "+-->") ) <+> annotate FileColor reportFile - in {- (2) -} hardline <> fileMarker + in {- (2) -} hardline <> reAnnotate sty fileMarker <> hardline - <+> {- (3) -} pipePrefix maxLineNumberLength withUnicode - <> {- (4) -} prettyAllLines fileContent withUnicode isError tabSize maxLineNumberLength sortedMarkersPerLine multilineMarkers allLineNumbers + <+> {- (3) -} {- (3) -} reAnnotate sty (pipePrefix maxLineNumberLength withUnicode) + <> {- (4) -} prettyAllLines sty fileContent withUnicode isError tabSize maxLineNumberLength sortedMarkersPerLine multilineMarkers allLineNumbers isThisMarker :: Marker msg -> Bool isThisMarker (This _) = True @@ -410,30 +411,30 @@ splitMarkersPerLine (m@(Position {..}, _) : ms) = -- | prettyAllLines :: - Pretty msg => + (Annotation -> ann) -> FileMap -> Bool -> Bool -> -- | The number of spaces each TAB character will span Int -> Int -> - [(Int, [(Position, Marker msg)])] -> - [(Position, Marker msg)] -> + [(Int, [(Position, Marker (Doc ann))])] -> + [(Position, Marker (Doc ann))] -> [Int] -> - Doc Annotation -prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNumbers = + Doc ann +prettyAllLines sty files withUnicode isError tabSize leftLen inline multiline lineNumbers = case lineNumbers of [] -> showMultiline True multiline [l] -> let (ms, doc) = showForLine True l in doc - <> prettyAllLines files withUnicode isError tabSize leftLen inline ms [] + <> prettyAllLines sty files withUnicode isError tabSize leftLen inline ms [] l1 : l2 : ls -> let (ms, doc) = showForLine False l1 in doc - <> (if l2 /= l1 + 1 then hardline <+> dotPrefix leftLen withUnicode else mempty) - <> prettyAllLines files withUnicode isError tabSize leftLen inline ms (l2 : ls) + <> (if l2 /= l1 + 1 then hardline <+> reAnnotate sty (dotPrefix leftLen withUnicode) else mempty) + <> prettyAllLines sty files withUnicode isError tabSize leftLen inline ms (l2 : ls) where showForLine isLastLine line = {- @@ -481,12 +482,12 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu allInlineMarkersInLine' = filter ((/=) Blank . snd) allInlineMarkersInLine allMultilineMarkersSpanningLine' = filter ((/=) Blank . snd) allMultilineMarkersSpanningLine - (widths, renderedCode) = getLine_ files (allInlineMarkersInLine <> allMultilineMarkersInLine <> allMultilineMarkersSpanningLine') line tabSize isError + (widths, renderedCode) = getLine_ sty files (allInlineMarkersInLine <> allMultilineMarkersInLine <> allMultilineMarkersSpanningLine') line tabSize isError in ( otherMultilines, hardline - <> {- (1) -} linePrefix leftLen line withUnicode <+> additionalPrefix + <> {- (1) -} reAnnotate sty (linePrefix leftLen line withUnicode <+> additionalPrefix) <> renderedCode - <> {- (2) -} showAllMarkersInLine (not $ null multiline) inSpanOfMultiline colorOfFirstMultilineMarker withUnicode isError leftLen widths allInlineMarkersInLine' + <> {- (2) -} showAllMarkersInLine sty (not $ null multiline) inSpanOfMultiline colorOfFirstMultilineMarker withUnicode isError leftLen widths allInlineMarkersInLine' <> showMultiline (isLastLine || List.safeLast multilineEndingOnLine == List.safeLast multiline) multilineEndingOnLine ) @@ -495,18 +496,18 @@ 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 = reAnnotate sty $ hardline <+> dotPrefix leftLen withUnicode <> space - prefixWithBar color = prefix <> maybe id annotate color (if withUnicode then "│ " else "| ") + prefixWithBar color = prefix <> maybe id (annotate . sty) color (if withUnicode then "│ " else "| ") showMultilineMarkerMessage (_, Blank) _ = mempty showMultilineMarkerMessage (_, marker) isLast = - annotate (markerColor isError marker) $ + annotate (sty (markerColor isError marker)) $ ( if isLast && isLastMultiline then if withUnicode then "╰╸ " else "`- " else if withUnicode then "├╸ " else "|- " ) - <> 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) (markerMessage marker) showMultilineMarkerMessages [] = [] showMultilineMarkerMessages [m] = [showMultilineMarkerMessage m True] @@ -515,17 +516,18 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu -- | getLine_ :: + (Annotation -> ann) -> FileMap -> [(Position, Marker msg)] -> Int -> Int -> Bool -> - (WidthTable, Doc Annotation) -getLine_ files markers line tabSize isError = + (WidthTable, Doc ann) +getLine_ sty files markers line tabSize isError = case safeArrayIndex (line - 1) =<< (HashMap.!?) files . file . fst =<< List.safeHead markers of Nothing -> ( mkWidthTable "", - annotate NoLineColor "" + annotate (sty NoLineColor) "" ) Just code -> ( mkWidthTable code, @@ -540,8 +542,8 @@ getLine_ files markers line tabSize isError = || (el == line && n < ec) || (bl < line && el > line) in maybe - (annotate CodeStyle) - ((\m -> annotate (MarkerStyle $ markerColor isError m)) . snd) + (annotate (sty CodeStyle)) + ((\m -> annotate (sty . MarkerStyle $ markerColor isError m)) . snd) (List.safeHead colorizingMarkers) cdoc ) @@ -554,16 +556,16 @@ 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 _ _ _ _ _ _ _ [] = mempty -showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUnicode isError leftLen widths ms = +showAllMarkersInLine :: (Annotation -> ann) -> Bool -> Bool -> (Doc Annotation -> Doc Annotation) -> Bool -> Bool -> Int -> WidthTable -> [(Position, Marker (Doc ann))] -> Doc ann +showAllMarkersInLine _ _ _ _ _ _ _ _ [] = mempty +showAllMarkersInLine sty 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 | 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 - hardline <+> dotPrefix leftLen withUnicode <+> (if List.null ms then mempty else specialPrefix <> showMarkers 1 maxMarkerColumn <> showMessages specialPrefix ms maxMarkerColumn) + hardline <+> reAnnotate sty (dotPrefix leftLen withUnicode <+> if List.null ms then mempty else specialPrefix <> showMarkers 1 maxMarkerColumn) <> showMessages specialPrefix ms maxMarkerColumn where widthAt i = 0 `fromMaybe` safeArrayIndex i widths widthsBetween start end = @@ -605,14 +607,14 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn lineStart pipes = let (n, docs) = allColumns 1 $ List.sortOn (snd . begin . fst) pipes numberOfSpaces = widthsBetween n bc - in dotPrefix leftLen withUnicode <+> specialPrefix <> fold docs <> pretty (replicate numberOfSpaces ' ') + in reAnnotate sty (dotPrefix leftLen withUnicode <+> specialPrefix) <> fold docs <> pretty (replicate numberOfSpaces ' ') -- the start of the line contains the "dot"-prefix as well as all the pipes for all the still not rendered marker messages prefix = 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 (sty (markerColor isError marker)) (if withUnicode then "│" else "|") -- pre-render pipes which are before because they will be shown lastBeginPosition = snd . begin . fst <$> List.safeLast (List.sortOn (snd . begin . fst) pipesAfter) @@ -634,13 +636,13 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn 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 (sty (markerColor isError marker)) (if withUnicode then "│" else "|") 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 (sty (markerColor isError msg)) (currentPipe <> pretty (replicate lineLen lineChar) <> pointChar) + <+> annotate (sty (markerColor isError msg)) (replaceLinesWith (hardline <+> lineStart pipesBeforeMessageRendered <+> if List.null pipesBeforeMessageStart then " " else " ") $ markerMessage msg) in hardline <+> prefix <> showMessages specialPrefix pipes lineLen -- WARN: uses the internal of the library @@ -689,16 +691,16 @@ markerMessage Blank = undefined {-# INLINE markerMessage #-} -- | Pretty prints all hints. -prettyAllHints :: Pretty msg => [Note msg] -> Int -> Bool -> Doc Annotation -prettyAllHints [] _ _ = mempty -prettyAllHints (h : hs) leftLen withUnicode = +prettyAllHints :: (Annotation -> ann) -> [Note (Doc ann)] -> Int -> Bool -> Doc ann +prettyAllHints _ [] _ _ = mempty +prettyAllHints sty (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)) - <> prettyAllHints hs leftLen withUnicode + let prefix = hardline <+> reAnnotate sty (pipePrefix leftLen withUnicode) + in prefix <+> annotate (sty HintColor) (notePrefix h <+> replaceLinesWith (prefix <+> " ") (noteMessage h)) + <> prettyAllHints sty hs leftLen withUnicode where notePrefix (Note _) = "Note:" notePrefix (Hint _) = "Hint:" diff --git a/src/Error/Diagnose/Style.hs b/src/Error/Diagnose/Style.hs index 46ee9f7..37ca6e0 100644 --- a/src/Error/Diagnose/Style.hs +++ b/src/Error/Diagnose/Style.hs @@ -13,13 +13,9 @@ module Error.Diagnose.Style -- * Default style specification defaultStyle, - - -- * Re-exports - reAnnotate, ) where -import Prettyprinter (Doc, reAnnotate) import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), bold, color, colorDull) -- $defining_new_styles @@ -75,7 +71,7 @@ data Annotation -- -- It transforms a 'Doc'ument containing 'Annotation's into a 'Doc'ument containing -- color information. -type Style = Doc Annotation -> Doc AnsiStyle +type Style = Annotation -> AnsiStyle ------------------------------------------- @@ -91,20 +87,18 @@ type Style = Doc Annotation -> Doc AnsiStyle -- * 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 = \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 From 92c36532ebcf20a978e63cdf323f789542e5158d Mon Sep 17 00:00:00 2001 From: Ellie Hermaszewska Date: Tue, 16 May 2023 11:22:27 +0800 Subject: [PATCH 03/16] Parameterize Annotation with some other annotation --- src/Error/Diagnose/Style.hs | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/src/Error/Diagnose/Style.hs b/src/Error/Diagnose/Style.hs index 37ca6e0..bd5c3dd 100644 --- a/src/Error/Diagnose/Style.hs +++ b/src/Error/Diagnose/Style.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveFunctor #-} + -- | -- Module : Error.Diagnose.Style -- Description : Custom style definitions @@ -37,7 +39,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 @@ -63,15 +65,18 @@ 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) -- | 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 = Annotation -> AnsiStyle +type Style a = Annotation a -> AnsiStyle ------------------------------------------- @@ -86,7 +91,7 @@ type Style = Annotation -> 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 :: Style AnsiStyle defaultStyle = \case ThisColor isError -> color if isError then Red else Yellow MaybeColor -> color Magenta @@ -102,3 +107,4 @@ defaultStyle = \case then ann else bold <> ann CodeStyle -> color White + OtherStyle s -> s From 559babd1be867dbdebb8e05f6aa89e7b175b948e Mon Sep 17 00:00:00 2001 From: Ellie Hermaszewska Date: Tue, 16 May 2023 11:23:43 +0800 Subject: [PATCH 04/16] Revert "add functionality for Doc messages" This reverts commit add174dbc07990ea993902bc9bddd6d5b64a6ca3. --- src/Error/Diagnose/Diagnostic/Internal.hs | 45 ++------- src/Error/Diagnose/Report/Internal.hs | 112 +++++++++++----------- src/Error/Diagnose/Style.hs | 4 + 3 files changed, 65 insertions(+), 96 deletions(-) diff --git a/src/Error/Diagnose/Diagnostic/Internal.hs b/src/Error/Diagnose/Diagnostic/Internal.hs index 99af858..bd01831 100644 --- a/src/Error/Diagnose/Diagnostic/Internal.hs +++ b/src/Error/Diagnose/Diagnostic/Internal.hs @@ -34,8 +34,8 @@ import Data.List (intersperse) import Error.Diagnose.Report (Report) import Error.Diagnose.Report.Internal (FileMap, errorToWarning, prettyReport, warningToError) import Error.Diagnose.Style (Annotation, Style) -import Prettyprinter (Doc, Pretty, hardline, unAnnotate, pretty) -import Prettyprinter.Render.Terminal (hPutDoc, AnsiStyle) +import Prettyprinter (Doc, Pretty, hardline, unAnnotate) +import Prettyprinter.Render.Terminal (hPutDoc) import System.IO (Handle) -- | The data type for diagnostic containing messages of an abstract type. @@ -108,25 +108,10 @@ prettyDiagnostic :: -- | The diagnostic to print. Diagnostic msg -> Doc Annotation -prettyDiagnostic withUnicode tabSize = - prettyDiagnostic' id withUnicode tabSize . fmap pretty +prettyDiagnostic withUnicode tabSize (Diagnostic reports file) = + fold . intersperse hardline $ prettyReport file withUnicode tabSize <$> toList reports {-# INLINE prettyDiagnostic #-} --- | Like 'prettyDiagnostic', but instead of requiring a 'Pretty' instance for --- diagnostic messages this allows you to provide your own 'Doc's -prettyDiagnostic' :: - -- | How to reannotate Diagnose's output - (Annotation -> ann) -> - -- | Should we use unicode when printing paths? - Bool -> - -- | The number of spaces each TAB character will span. - Int -> - -- | The diagnostic to print. - Diagnostic (Doc ann) -> - Doc ann -prettyDiagnostic' sty withUnicode tabSize (Diagnostic reports file) = - fold . intersperse hardline $ prettyReport sty file withUnicode tabSize <$> toList reports - -- | Prints a 'Diagnostic' onto a specific 'Handle'. printDiagnostic :: (MonadIO m, Pretty msg) => @@ -143,28 +128,10 @@ printDiagnostic :: -- | The diagnostic to output. Diagnostic msg -> m () -printDiagnostic handle withUnicode withColors tabSize style = - printDiagnostic' handle withUnicode tabSize (if withColors then style else const mempty) . fmap pretty +printDiagnostic handle withUnicode withColors tabSize style diag = + liftIO $ hPutDoc handle ((if withColors then style else unAnnotate) $ prettyDiagnostic withUnicode tabSize diag) {-# INLINE printDiagnostic #-} --- | Like 'printDiagnostic', but instead of requiring a 'Pretty' instance for --- diagnostic messages this allows you to provide your own 'Doc's -printDiagnostic' :: - (MonadIO m) => - -- | The handle onto which to output the diagnostic. - Handle -> - -- | Should we print with unicode characters? - Bool -> - -- | The number of spaces each TAB character will span. - Int -> - -- | How to reannotate Diagnose's output - (Annotation -> AnsiStyle) -> - -- | The diagnostic to output. - Diagnostic (Doc AnsiStyle) -> - m () -printDiagnostic' handle withUnicode tabSize sty diag = - liftIO $ hPutDoc handle (prettyDiagnostic' sty withUnicode tabSize diag) - -- | Inserts a new referenceable file within the diagnostic. addFile :: Diagnostic msg -> diff --git a/src/Error/Diagnose/Report/Internal.hs b/src/Error/Diagnose/Report/Internal.hs index fa2d845..4c42ead 100644 --- a/src/Error/Diagnose/Report/Internal.hs +++ b/src/Error/Diagnose/Report/Internal.hs @@ -50,7 +50,7 @@ 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, (<+>), reAnnotate) +import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>)) import Prettyprinter.Internal (Doc (..)) type FileMap = HashMap FilePath (Array Int String) @@ -195,8 +195,7 @@ errorToWarning r@(Report False _ _ _ _) = r -- | Pretty prints a report to a 'Doc' handling colors. prettyReport :: - -- | How to reannotate Diagnose's output - (Annotation -> ann) -> + Pretty msg => -- | The content of the file the reports are for FileMap -> -- | Should we print paths in unicode? @@ -204,9 +203,9 @@ prettyReport :: -- | The number of spaces each TAB character will span Int -> -- | The whole report to output - Report (Doc ann) -> - Doc ann -prettyReport sty fileContent withUnicode tabSize (Report isError code message markers hints) = + Report msg -> + 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 @@ -218,7 +217,7 @@ prettyReport sty fileContent withUnicode tabSize (Report isError code message ma header = annotate - (sty (KindColor isError)) + (KindColor isError) ( lbracket <> ( if isError then "error" @@ -226,7 +225,7 @@ prettyReport sty fileContent withUnicode tabSize (Report isError code message ma ) <> case code of Nothing -> rbracket - Just code -> space <> code <> rbracket + Just code -> space <> pretty code <> rbracket ) in {- A report is of the form: @@ -241,19 +240,19 @@ prettyReport sty fileContent withUnicode tabSize (Report isError code message ma (6) -------+ -} - {- (1) -} header <> colon <+> align message - <> {- (2), (3), (4) -} foldMap (uncurry (prettySubReport sty fileContent withUnicode isError tabSize maxLineNumberLength)) groupedMarkers + {- (1) -} header <> colon <+> align (pretty message) + <> {- (2), (3), (4) -} fold (uncurry (prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength) <$> groupedMarkers) <> {- (5) -} ( if | null hints && null markers -> mempty | null hints -> mempty - | otherwise -> hardline <+> reAnnotate sty (dotPrefix maxLineNumberLength withUnicode) + | otherwise -> hardline <+> dotPrefix maxLineNumberLength withUnicode ) - <> prettyAllHints sty hints maxLineNumberLength withUnicode + <> prettyAllHints hints maxLineNumberLength withUnicode <> hardline <> {- (6) -} ( if null markers && null hints then mempty else - annotate (sty RuleColor) (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 ) @@ -329,6 +328,7 @@ ellipsisPrefix :: ellipsisPrefix leftLen withUnicode = pad leftLen ' ' mempty <> annotate RuleColor (if withUnicode then space <> "⋮" else "...") groupMarkersPerFile :: + Pretty msg => [(Position, Marker msg)] -> [(Bool, [(Position, Marker msg)])] groupMarkersPerFile [] = [] @@ -352,8 +352,7 @@ groupMarkersPerFile markers = -- | Prettyprint a sub-report, which is a part of the report spanning across a single file prettySubReport :: - -- | How to reannotate Diagnose's output - (Annotation -> ann) -> + Pretty msg => -- | The content of files in the diagnostics FileMap -> -- | Is the output done with Unicode characters? @@ -367,9 +366,9 @@ prettySubReport :: -- | Is this sub-report the first one in the list? Bool -> -- | The list of line-ordered markers appearing in a single file - [(Position, Marker (Doc ann))] -> - Doc ann -prettySubReport sty fileContent withUnicode isError tabSize maxLineNumberLength isFirst markers = + [(Position, Marker msg)] -> + 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 @@ -391,10 +390,10 @@ prettySubReport sty fileContent withUnicode isError tabSize maxLineNumberLength <> annotate RuleColor (if withUnicode then "┼──▶" else "+-->") ) <+> annotate FileColor reportFile - in {- (2) -} hardline <> reAnnotate sty fileMarker + in {- (2) -} hardline <> fileMarker <> hardline - <+> {- (3) -} {- (3) -} reAnnotate sty (pipePrefix maxLineNumberLength withUnicode) - <> {- (4) -} prettyAllLines sty fileContent withUnicode isError tabSize maxLineNumberLength sortedMarkersPerLine multilineMarkers allLineNumbers + <+> {- (3) -} pipePrefix maxLineNumberLength withUnicode + <> {- (4) -} prettyAllLines fileContent withUnicode isError tabSize maxLineNumberLength sortedMarkersPerLine multilineMarkers allLineNumbers isThisMarker :: Marker msg -> Bool isThisMarker (This _) = True @@ -411,30 +410,30 @@ splitMarkersPerLine (m@(Position {..}, _) : ms) = -- | prettyAllLines :: - (Annotation -> ann) -> + Pretty msg => FileMap -> Bool -> Bool -> -- | The number of spaces each TAB character will span Int -> Int -> - [(Int, [(Position, Marker (Doc ann))])] -> - [(Position, Marker (Doc ann))] -> + [(Int, [(Position, Marker msg)])] -> + [(Position, Marker msg)] -> [Int] -> - Doc ann -prettyAllLines sty files withUnicode isError tabSize leftLen inline multiline lineNumbers = + Doc Annotation +prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNumbers = case lineNumbers of [] -> showMultiline True multiline [l] -> let (ms, doc) = showForLine True l in doc - <> prettyAllLines sty files withUnicode isError tabSize leftLen inline ms [] + <> prettyAllLines files withUnicode isError tabSize leftLen inline ms [] l1 : l2 : ls -> let (ms, doc) = showForLine False l1 in doc - <> (if l2 /= l1 + 1 then hardline <+> reAnnotate sty (dotPrefix leftLen withUnicode) else mempty) - <> prettyAllLines sty files withUnicode isError tabSize leftLen inline ms (l2 : ls) + <> (if l2 /= l1 + 1 then hardline <+> dotPrefix leftLen withUnicode else mempty) + <> prettyAllLines files withUnicode isError tabSize leftLen inline ms (l2 : ls) where showForLine isLastLine line = {- @@ -482,12 +481,12 @@ prettyAllLines sty files withUnicode isError tabSize leftLen inline multiline li allInlineMarkersInLine' = filter ((/=) Blank . snd) allInlineMarkersInLine allMultilineMarkersSpanningLine' = filter ((/=) Blank . snd) allMultilineMarkersSpanningLine - (widths, renderedCode) = getLine_ sty files (allInlineMarkersInLine <> allMultilineMarkersInLine <> allMultilineMarkersSpanningLine') line tabSize isError + (widths, renderedCode) = getLine_ files (allInlineMarkersInLine <> allMultilineMarkersInLine <> allMultilineMarkersSpanningLine') line tabSize isError in ( otherMultilines, hardline - <> {- (1) -} reAnnotate sty (linePrefix leftLen line withUnicode <+> additionalPrefix) + <> {- (1) -} linePrefix leftLen line withUnicode <+> additionalPrefix <> renderedCode - <> {- (2) -} showAllMarkersInLine sty (not $ null multiline) inSpanOfMultiline colorOfFirstMultilineMarker withUnicode isError leftLen widths allInlineMarkersInLine' + <> {- (2) -} showAllMarkersInLine (not $ null multiline) inSpanOfMultiline colorOfFirstMultilineMarker withUnicode isError leftLen widths allInlineMarkersInLine' <> showMultiline (isLastLine || List.safeLast multilineEndingOnLine == List.safeLast multiline) multilineEndingOnLine ) @@ -496,18 +495,18 @@ prettyAllLines sty files withUnicode isError tabSize leftLen inline multiline li 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 = reAnnotate sty $ hardline <+> dotPrefix leftLen withUnicode <> space + prefix = hardline <+> dotPrefix leftLen withUnicode <> space - prefixWithBar color = prefix <> maybe id (annotate . sty) color (if withUnicode then "│ " else "| ") + prefixWithBar color = prefix <> maybe id annotate color (if withUnicode then "│ " else "| ") showMultilineMarkerMessage (_, Blank) _ = mempty showMultilineMarkerMessage (_, marker) isLast = - annotate (sty (markerColor isError marker)) $ + annotate (markerColor isError marker) $ ( if isLast && isLastMultiline then if withUnicode then "╰╸ " else "`- " else if withUnicode then "├╸ " else "|- " ) - <> replaceLinesWith (if isLast then prefix <> " " else prefixWithBar (Just $ markerColor isError marker) <> space) (markerMessage marker) + <> replaceLinesWith (if isLast then prefix <> " " else prefixWithBar (Just $ markerColor isError marker) <> space) (pretty $ markerMessage marker) showMultilineMarkerMessages [] = [] showMultilineMarkerMessages [m] = [showMultilineMarkerMessage m True] @@ -516,18 +515,17 @@ prettyAllLines sty files withUnicode isError tabSize leftLen inline multiline li -- | getLine_ :: - (Annotation -> ann) -> FileMap -> [(Position, Marker msg)] -> Int -> Int -> Bool -> - (WidthTable, Doc ann) -getLine_ sty files markers line tabSize isError = + (WidthTable, Doc Annotation) +getLine_ files markers line tabSize isError = case safeArrayIndex (line - 1) =<< (HashMap.!?) files . file . fst =<< List.safeHead markers of Nothing -> ( mkWidthTable "", - annotate (sty NoLineColor) "" + annotate NoLineColor "" ) Just code -> ( mkWidthTable code, @@ -542,8 +540,8 @@ getLine_ sty files markers line tabSize isError = || (el == line && n < ec) || (bl < line && el > line) in maybe - (annotate (sty CodeStyle)) - ((\m -> annotate (sty . MarkerStyle $ markerColor isError m)) . snd) + (annotate CodeStyle) + ((\m -> annotate (MarkerStyle $ markerColor isError m)) . snd) (List.safeHead colorizingMarkers) cdoc ) @@ -556,16 +554,16 @@ getLine_ sty files markers line tabSize isError = mkWidthTable s = listArray (1, length s) (ifTab tabSize wcwidth <$> s) -- | -showAllMarkersInLine :: (Annotation -> ann) -> Bool -> Bool -> (Doc Annotation -> Doc Annotation) -> Bool -> Bool -> Int -> WidthTable -> [(Position, Marker (Doc ann))] -> Doc ann -showAllMarkersInLine _ _ _ _ _ _ _ _ [] = mempty -showAllMarkersInLine sty hasMultilines inSpanOfMultiline colorMultilinePrefix withUnicode isError leftLen widths ms = +showAllMarkersInLine :: Pretty msg => Bool -> Bool -> (Doc Annotation -> Doc Annotation) -> Bool -> Bool -> Int -> WidthTable -> [(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 specialPrefix | inSpanOfMultiline = colorMultilinePrefix (if withUnicode then "│ " else "| ") <> 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 - hardline <+> reAnnotate sty (dotPrefix leftLen withUnicode <+> if List.null ms then mempty else specialPrefix <> showMarkers 1 maxMarkerColumn) <> showMessages specialPrefix ms maxMarkerColumn + hardline <+> dotPrefix leftLen withUnicode <+> (if List.null ms then mempty else specialPrefix <> showMarkers 1 maxMarkerColumn <> showMessages specialPrefix ms maxMarkerColumn) where widthAt i = 0 `fromMaybe` safeArrayIndex i widths widthsBetween start end = @@ -607,14 +605,14 @@ showAllMarkersInLine sty hasMultilines inSpanOfMultiline colorMultilinePrefix wi lineStart pipes = let (n, docs) = allColumns 1 $ List.sortOn (snd . begin . fst) pipes numberOfSpaces = widthsBetween n bc - in reAnnotate sty (dotPrefix leftLen withUnicode <+> specialPrefix) <> fold docs <> pretty (replicate numberOfSpaces ' ') + in dotPrefix leftLen withUnicode <+> specialPrefix <> fold docs <> pretty (replicate numberOfSpaces ' ') -- the start of the line contains the "dot"-prefix as well as all the pipes for all the still not rendered marker messages prefix = 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 (sty (markerColor isError marker)) (if withUnicode then "│" else "|") + pipesBeforeRendered = pipesBefore <&> second \marker -> annotate (markerColor isError marker) (if withUnicode then "│" else "|") -- pre-render pipes which are before because they will be shown lastBeginPosition = snd . begin . fst <$> List.safeLast (List.sortOn (snd . begin . fst) pipesAfter) @@ -636,13 +634,13 @@ showAllMarkersInLine sty hasMultilines inSpanOfMultiline colorMultilinePrefix wi 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 (sty (markerColor isError marker)) (if withUnicode then "│" else "|") + pipesBeforeMessageRendered = (pipesBefore <> pipesBeforeMessageStart) <&> second \marker -> annotate (markerColor isError marker) (if withUnicode then "│" else "|") 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 (sty (markerColor isError msg)) (currentPipe <> pretty (replicate lineLen lineChar) <> pointChar) - <+> annotate (sty (markerColor isError msg)) (replaceLinesWith (hardline <+> lineStart pipesBeforeMessageRendered <+> if List.null pipesBeforeMessageStart then " " else " ") $ markerMessage msg) + <> 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) in hardline <+> prefix <> showMessages specialPrefix pipes lineLen -- WARN: uses the internal of the library @@ -691,16 +689,16 @@ markerMessage Blank = undefined {-# INLINE markerMessage #-} -- | Pretty prints all hints. -prettyAllHints :: (Annotation -> ann) -> [Note (Doc ann)] -> Int -> Bool -> Doc ann -prettyAllHints _ [] _ _ = mempty -prettyAllHints sty (h : hs) leftLen withUnicode = +prettyAllHints :: Pretty msg => [Note msg] -> Int -> Bool -> Doc Annotation +prettyAllHints [] _ _ = mempty +prettyAllHints (h : hs) leftLen withUnicode = {- A hint is composed of: (1) : Hint: -} - let prefix = hardline <+> reAnnotate sty (pipePrefix leftLen withUnicode) - in prefix <+> annotate (sty HintColor) (notePrefix h <+> replaceLinesWith (prefix <+> " ") (noteMessage h)) - <> prettyAllHints sty hs leftLen withUnicode + let prefix = hardline <+> pipePrefix leftLen withUnicode + in prefix <+> annotate HintColor (notePrefix h <+> replaceLinesWith (prefix <+> " ") (pretty $ noteMessage h)) + <> prettyAllHints hs leftLen withUnicode where notePrefix (Note _) = "Note:" notePrefix (Hint _) = "Hint:" diff --git a/src/Error/Diagnose/Style.hs b/src/Error/Diagnose/Style.hs index bd5c3dd..ec9856c 100644 --- a/src/Error/Diagnose/Style.hs +++ b/src/Error/Diagnose/Style.hs @@ -15,9 +15,13 @@ module Error.Diagnose.Style -- * Default style specification defaultStyle, + + -- * Re-exports + reAnnotate, ) where +import Prettyprinter (Doc, reAnnotate) import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), bold, color, colorDull) -- $defining_new_styles From 21d08763e42d2dc07fdf6f8115e894a2086b6892 Mon Sep 17 00:00:00 2001 From: Ellie Hermaszewska Date: Tue, 16 May 2023 11:54:22 +0800 Subject: [PATCH 05/16] Add functionality to render diagnostics with user provided Docs --- src/Error/Diagnose/Diagnostic.hs | 2 + src/Error/Diagnose/Diagnostic/Internal.hs | 56 ++++++++++++++++++----- src/Error/Diagnose/Pretty.hs | 1 - src/Error/Diagnose/Report/Internal.hs | 49 ++++++++++---------- src/Error/Diagnose/Style.hs | 11 +++-- test/rendering/Spec.hs | 4 +- 6 files changed, 79 insertions(+), 44 deletions(-) diff --git a/src/Error/Diagnose/Diagnostic.hs b/src/Error/Diagnose/Diagnostic.hs index fcc9e04..b9cb4a5 100644 --- a/src/Error/Diagnose/Diagnostic.hs +++ b/src/Error/Diagnose/Diagnostic.hs @@ -25,7 +25,9 @@ import Error.Diagnose.Diagnostic.Internal as Export hasReports, reportsOf, prettyDiagnostic, + prettyDiagnostic', printDiagnostic, + printDiagnostic', warningsToErrors, ) import System.IO as Export (stderr, stdout) diff --git a/src/Error/Diagnose/Diagnostic/Internal.hs b/src/Error/Diagnose/Diagnostic/Internal.hs index bd01831..11f8c5f 100644 --- a/src/Error/Diagnose/Diagnostic/Internal.hs +++ b/src/Error/Diagnose/Diagnostic/Internal.hs @@ -34,8 +34,8 @@ import Data.List (intersperse) import Error.Diagnose.Report (Report) import Error.Diagnose.Report.Internal (FileMap, errorToWarning, prettyReport, warningToError) 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. @@ -107,11 +107,25 @@ prettyDiagnostic :: Int -> -- | 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? + Bool -> + -- | The number of spaces each TAB character will span. + Int -> + -- | 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) => @@ -119,18 +133,38 @@ printDiagnostic :: Handle -> -- | Should we print with unicode characters? Bool -> - -- | 'False' to disable colors. + -- | The number of spaces each TAB character will span. + Int -> + -- | The style in which to output the diagnostic. + Style ann -> + -- | The diagnostic to output. + Diagnostic msg -> + m () +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? Bool -> -- | The number of spaces each TAB character will span. Int -> -- | The style in which to output the diagnostic. - Style -> + Style ann -> -- | The diagnostic to output. - Diagnostic msg -> + Diagnostic (Doc ann) -> m () -printDiagnostic handle withUnicode withColors tabSize style diag = - liftIO $ hPutDoc handle ((if withColors then style else unAnnotate) $ prettyDiagnostic withUnicode tabSize diag) -{-# INLINE printDiagnostic #-} +printDiagnostic' handle withUnicode tabSize style = + liftIO + . renderIO handle + . reAnnotateS style + . layoutPretty defaultLayoutOptions + . prettyDiagnostic' withUnicode tabSize -- | Inserts a new referenceable file within the diagnostic. addFile :: 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 4c42ead..133d111 100644 --- a/src/Error/Diagnose/Report/Internal.hs +++ b/src/Error/Diagnose/Report/Internal.hs @@ -50,7 +50,7 @@ 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 (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>), reAnnotate) import Prettyprinter.Internal (Doc (..)) type FileMap = HashMap FilePath (Array Int String) @@ -195,7 +195,6 @@ errorToWarning r@(Report False _ _ _ _) = r -- | 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? @@ -203,8 +202,8 @@ prettyReport :: -- | The number of spaces each TAB character will span Int -> -- | 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 @@ -225,7 +224,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: @@ -240,7 +239,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 @@ -275,7 +274,7 @@ dotPrefix :: Int -> -- | Whether to print with unicode characters or not. Bool -> - Doc Annotation + Doc (Annotation ann) dotPrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (if withUnicode then "•" else ":") {-# INLINE dotPrefix #-} @@ -290,7 +289,7 @@ pipePrefix :: Int -> -- | Whether to print with unicode characters or not. Bool -> - Doc Annotation + Doc (Annotation ann) pipePrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (if withUnicode then "│" else "|") {-# INLINE pipePrefix #-} @@ -309,7 +308,7 @@ linePrefix :: Int -> -- | Whether to use unicode characters or not. Bool -> - Doc Annotation + 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 "|" @@ -324,11 +323,10 @@ linePrefix leftLen lineNo withUnicode = ellipsisPrefix :: Int -> Bool -> - Doc Annotation + Doc (Annotation ann) ellipsisPrefix leftLen withUnicode = pad leftLen ' ' mempty <> annotate RuleColor (if withUnicode then space <> "⋮" else "...") groupMarkersPerFile :: - Pretty msg => [(Position, Marker msg)] -> [(Bool, [(Position, Marker msg)])] groupMarkersPerFile [] = [] @@ -352,7 +350,6 @@ 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? @@ -366,8 +363,8 @@ prettySubReport :: -- | 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 @@ -410,17 +407,16 @@ splitMarkersPerLine (m@(Position {..}, _) : ms) = -- | prettyAllLines :: - Pretty msg => FileMap -> Bool -> Bool -> -- | The number of spaces each TAB character will span 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 [] -> @@ -506,7 +502,7 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu then if withUnicode then "╰╸ " else "`- " else if withUnicode then "├╸ " else "|- " ) - <> 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) (annotated $ markerMessage marker) showMultilineMarkerMessages [] = [] showMultilineMarkerMessages [m] = [showMultilineMarkerMessage m True] @@ -520,7 +516,7 @@ getLine_ :: Int -> Int -> Bool -> - (WidthTable, Doc Annotation) + (WidthTable, Doc (Annotation ann)) getLine_ files markers line tabSize isError = case safeArrayIndex (line - 1) =<< (HashMap.!?) files . file . fst =<< List.safeHead markers of Nothing -> @@ -554,7 +550,7 @@ 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)) -> Bool -> 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 @@ -640,7 +636,7 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn 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 (hardline <+> lineStart pipesBeforeMessageRendered <+> if List.null pipesBeforeMessageStart then " " else " ") $ annotated $ markerMessage msg) in hardline <+> prefix <> showMessages specialPrefix pipes lineLen -- WARN: uses the internal of the library @@ -673,7 +669,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 @@ -689,7 +685,7 @@ markerMessage Blank = undefined {-# INLINE markerMessage #-} -- | Pretty prints all hints. -prettyAllHints :: Pretty msg => [Note msg] -> Int -> Bool -> Doc Annotation +prettyAllHints :: [Note (Doc ann)] -> Int -> Bool -> Doc (Annotation ann) prettyAllHints [] _ _ = mempty prettyAllHints (h : hs) leftLen withUnicode = {- @@ -697,7 +693,7 @@ prettyAllHints (h : hs) leftLen withUnicode = (1) : Hint: -} let prefix = hardline <+> pipePrefix leftLen withUnicode - in prefix <+> annotate HintColor (notePrefix h <+> replaceLinesWith (prefix <+> " ") (pretty $ noteMessage h)) + in prefix <+> annotate HintColor (notePrefix h <+> replaceLinesWith (prefix <+> " ") (annotated $ noteMessage h)) <> prettyAllHints hs leftLen withUnicode where notePrefix (Note _) = "Note:" @@ -710,3 +706,6 @@ 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 diff --git a/src/Error/Diagnose/Style.hs b/src/Error/Diagnose/Style.hs index ec9856c..5ba6808 100644 --- a/src/Error/Diagnose/Style.hs +++ b/src/Error/Diagnose/Style.hs @@ -13,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 @@ -84,6 +81,10 @@ 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 diff --git a/test/rendering/Spec.hs b/test/rendering/Spec.hs index 1193ee9..30cad15 100644 --- a/test/rendering/Spec.hs +++ b/test/rendering/Spec.hs @@ -77,9 +77,9 @@ main = do let diag = HashMap.foldlWithKey' addFile (foldl addReport def reports) files hPutStrLn stdout "\n\nWith unicode: ─────────────────────────\n" - printDiagnostic stdout True True 4 defaultStyle diag + printDiagnostic stdout True 4 defaultStyle diag hPutStrLn stdout "\n\nWithout unicode: ----------------------\n" - printDiagnostic stdout False True 4 defaultStyle diag + printDiagnostic stdout False 4 defaultStyle diag #ifdef USE_AESON hPutStrLn stdout "\n\nAs JSON: ------------------------------\n" BS.hPutStr stdout (diagnosticToJson diag) From 7634d1550249db121e746897d62216d042686604 Mon Sep 17 00:00:00 2001 From: Ellie Hermaszewska Date: Tue, 16 May 2023 11:57:55 +0800 Subject: [PATCH 06/16] Remove color parameter from tests --- README.md | 2 +- src/Error/Diagnose.hs | 4 ++-- test/megaparsec/Repro6.hs | 6 +++--- test/megaparsec/Spec.hs | 4 ++-- test/parsec/Repro2.hs | 4 ++-- test/parsec/Spec.hs | 6 +++--- 6 files changed, 13 insertions(+), 13 deletions(-) diff --git a/README.md b/README.md index 1edbab8..df7820f 100644 --- a/README.md +++ b/README.md @@ -103,7 +103,7 @@ 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' +printDiagnostic stdout True 4 defaultStyle diagnostic' ``` More examples are given in the [`test/rendering`](./test/rendering) folder (execute `stack test` to see the output). 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/test/megaparsec/Repro6.hs b/test/megaparsec/Repro6.hs index d906d6f..dcc5ba7 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 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) + Left diag -> printDiagnostic stdout 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) + Left diag -> printDiagnostic stdout True 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..4a57382 100644 --- a/test/megaparsec/Spec.hs +++ b/test/megaparsec/Spec.hs @@ -29,10 +29,10 @@ 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) + Left diag -> printDiagnostic stdout 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) + Left diag -> printDiagnostic stdout True 4 defaultStyle (addFile diag filename (Text.unpack content2) :: Diagnostic String) Right res -> print res putStrLn "---------------------------------------------------" diff --git a/test/parsec/Repro2.hs b/test/parsec/Repro2.hs index b2c8d38..256bdc0 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 True 4 defaultStyle) print $ diagParse parser1 "issues/2.txt" "\\1" + either (printDiagnostic stderr True 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..87cb712 100644 --- a/test/parsec/Spec.hs +++ b/test/parsec/Spec.hs @@ -32,13 +32,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 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) + Left diag -> printDiagnostic stdout True 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 True 4 defaultStyle (addFile diag filename (Text.unpack content3) :: Diagnostic String) Right res -> print res -- all issue reproduction From 1578e3e38877ebca63cb060b4d47e84d558377ae Mon Sep 17 00:00:00 2001 From: Ellie Hermaszewska Date: Tue, 16 May 2023 12:25:10 +0800 Subject: [PATCH 07/16] Make interface a little more typesafe with WithUnicode and TabSize --- src/Error/Diagnose/Diagnostic.hs | 2 + src/Error/Diagnose/Diagnostic/Internal.hs | 20 ++--- src/Error/Diagnose/Report/Internal.hs | 100 +++++++++++----------- test/megaparsec/Repro6.hs | 6 +- test/megaparsec/Spec.hs | 8 +- test/parsec/Repro2.hs | 4 +- test/parsec/Spec.hs | 6 +- test/rendering/Spec.hs | 6 +- 8 files changed, 80 insertions(+), 72 deletions(-) diff --git a/src/Error/Diagnose/Diagnostic.hs b/src/Error/Diagnose/Diagnostic.hs index b9cb4a5..c2f5a81 100644 --- a/src/Error/Diagnose/Diagnostic.hs +++ b/src/Error/Diagnose/Diagnostic.hs @@ -29,5 +29,7 @@ import Error.Diagnose.Diagnostic.Internal as Export 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 11f8c5f..d263d1c 100644 --- a/src/Error/Diagnose/Diagnostic/Internal.hs +++ b/src/Error/Diagnose/Diagnostic/Internal.hs @@ -16,7 +16,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 @@ -32,7 +32,7 @@ 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, pretty, defaultLayoutOptions, reAnnotateS, layoutPretty) import Prettyprinter.Render.Terminal (renderIO) @@ -102,9 +102,9 @@ 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 ann) @@ -117,9 +117,9 @@ prettyDiagnostic withUnicode tabSize = -- annotations are retained in 'OtherStyle' prettyDiagnostic' :: -- | 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 (Doc ann) -> Doc (Annotation ann) @@ -132,9 +132,9 @@ printDiagnostic :: -- | The handle onto which to output the diagnostic. Handle -> -- | Should we print with unicode characters? - Bool -> + WithUnicode -> -- | The number of spaces each TAB character will span. - Int -> + TabSize -> -- | The style in which to output the diagnostic. Style ann -> -- | The diagnostic to output. @@ -151,9 +151,9 @@ printDiagnostic' :: -- | The handle onto which to output the diagnostic. Handle -> -- | Should we print with unicode characters? - Bool -> + WithUnicode -> -- | The number of spaces each TAB character will span. - Int -> + TabSize -> -- | The style in which to output the diagnostic. Style ann -> -- | The diagnostic to output. diff --git a/src/Error/Diagnose/Report/Internal.hs b/src/Error/Diagnose/Report/Internal.hs index 133d111..f667d0f 100644 --- a/src/Error/Diagnose/Report/Internal.hs +++ b/src/Error/Diagnose/Report/Internal.hs @@ -26,6 +26,8 @@ module Error.Diagnose.Report.Internal ( module Error.Diagnose.Report.Internal , Report(.., Warn, Err) + , WithUnicode(..) + , TabSize(..) ) where #ifdef USE_AESON @@ -52,6 +54,7 @@ import Error.Diagnose.Position import Error.Diagnose.Style (Annotation (..)) import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>), reAnnotate) import Prettyprinter.Internal (Doc (..)) +import Data.Bool (bool) type FileMap = HashMap FilePath (Array Int String) @@ -193,14 +196,18 @@ 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 :: -- | 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 (Doc ann) -> Doc (Annotation ann) @@ -251,7 +258,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 ) @@ -273,9 +280,11 @@ dotPrefix :: -- | The length of the left space before the bullet. Int -> -- | Whether to print with unicode characters or not. - Bool -> + WithUnicode -> Doc (Annotation ann) -dotPrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (if withUnicode then "•" else ":") +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. @@ -288,9 +297,9 @@ pipePrefix :: -- | The length of the left space before the pipe. Int -> -- | Whether to print with unicode characters or not. - Bool -> + WithUnicode -> Doc (Annotation ann) -pipePrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (if withUnicode then "│" else "|") +pipePrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (unicode "|" "│" withUnicode) {-# INLINE pipePrefix #-} -- | Creates a line-prefix for a report line containing source code @@ -307,11 +316,11 @@ linePrefix :: -- | The line number to show. Int -> -- | Whether to use unicode characters or not. - Bool -> + 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. @@ -322,9 +331,9 @@ linePrefix leftLen lineNo withUnicode = -- [without unicode] "@␣␣␣␣...@" ellipsisPrefix :: Int -> - Bool -> + WithUnicode -> Doc (Annotation ann) -ellipsisPrefix leftLen withUnicode = pad leftLen ' ' mempty <> annotate RuleColor (if withUnicode then space <> "⋮" else "...") +ellipsisPrefix leftLen withUnicode = pad leftLen ' ' mempty <> annotate RuleColor (unicode "..." (space <> "⋮") withUnicode) groupMarkersPerFile :: [(Position, Marker msg)] -> @@ -353,11 +362,11 @@ prettySubReport :: -- | 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? @@ -380,16 +389,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 @@ -408,10 +417,10 @@ splitMarkersPerLine (m@(Position {..}, _) : ms) = -- | prettyAllLines :: FileMap -> - Bool -> + WithUnicode -> Bool -> -- | The number of spaces each TAB character will span - Int -> + TabSize -> Int -> [(Int, [(Position, Marker (Doc ann))])] -> [(Position, Marker (Doc ann))] -> @@ -458,19 +467,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 @@ -480,7 +484,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 @@ -493,14 +497,14 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu prefix = hardline <+> 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) (annotated $ markerMessage marker) @@ -514,10 +518,10 @@ getLine_ :: FileMap -> [(Position, Marker msg)] -> Int -> - Int -> + TabSize -> Bool -> (WidthTable, Doc (Annotation ann)) -getLine_ files markers line tabSize isError = +getLine_ files markers line (TabSize tabSize) isError = case safeArrayIndex (line - 1) =<< (HashMap.!?) files . file . fst =<< List.safeHead markers of Nothing -> ( mkWidthTable "", @@ -550,12 +554,12 @@ getLine_ files markers line tabSize isError = mkWidthTable s = listArray (1, length s) (ifTab tabSize wcwidth <$> s) -- | -showAllMarkersInLine :: Bool -> Bool -> (Doc (Annotation ann) -> Doc (Annotation ann)) -> Bool -> Bool -> Int -> WidthTable -> [(Position, Marker (Doc ann))] -> Doc (Annotation ann) +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 @@ -576,8 +580,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 @@ -608,7 +612,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) @@ -617,20 +621,15 @@ 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 @@ -685,7 +684,7 @@ markerMessage Blank = undefined {-# INLINE markerMessage #-} -- | Pretty prints all hints. -prettyAllHints :: [Note (Doc ann)] -> Int -> Bool -> Doc (Annotation ann) +prettyAllHints :: [Note (Doc ann)] -> Int -> WithUnicode -> Doc (Annotation ann) prettyAllHints [] _ _ = mempty prettyAllHints (h : hs) leftLen withUnicode = {- @@ -709,3 +708,8 @@ safeArrayIndex i a 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/test/megaparsec/Repro6.hs b/test/megaparsec/Repro6.hs index dcc5ba7..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 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 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 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 4a57382..8e3463b 100644 --- a/test/megaparsec/Spec.hs +++ b/test/megaparsec/Spec.hs @@ -29,11 +29,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 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 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 256bdc0..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 4 defaultStyle) print $ diagParse parser1 "issues/2.txt" "\\1" - either (printDiagnostic stderr 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 87cb712..512fb49 100644 --- a/test/parsec/Spec.hs +++ b/test/parsec/Spec.hs @@ -32,13 +32,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 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 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 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 30cad15..cb905ed 100644 --- a/test/rendering/Spec.hs +++ b/test/rendering/Spec.hs @@ -17,6 +17,8 @@ import Error.Diagnose defaultStyle, printDiagnostic, stdout, + WithUnicode (..), + TabSize (..), ) import System.IO (hPutStrLn) @@ -77,9 +79,9 @@ main = do let diag = HashMap.foldlWithKey' addFile (foldl addReport def reports) files hPutStrLn stdout "\n\nWith unicode: ─────────────────────────\n" - printDiagnostic stdout True 4 defaultStyle diag + printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle diag hPutStrLn stdout "\n\nWithout unicode: ----------------------\n" - printDiagnostic stdout False 4 defaultStyle diag + printDiagnostic stdout WithoutUnicode (TabSize 4) defaultStyle diag #ifdef USE_AESON hPutStrLn stdout "\n\nAs JSON: ------------------------------\n" BS.hPutStr stdout (diagnosticToJson diag) From 717e47c953b0837bde3f9129a7b78d002123fa14 Mon Sep 17 00:00:00 2001 From: Ellie Hermaszewska Date: Tue, 16 May 2023 12:25:25 +0800 Subject: [PATCH 08/16] squash a couple of errors and warnings in the testsuite --- test/megaparsec/Spec.hs | 1 - test/rendering/Spec.hs | 1 + 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/test/megaparsec/Spec.hs b/test/megaparsec/Spec.hs index 8e3463b..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 () diff --git a/test/rendering/Spec.hs b/test/rendering/Spec.hs index cb905ed..c407094 100644 --- a/test/rendering/Spec.hs +++ b/test/rendering/Spec.hs @@ -17,6 +17,7 @@ import Error.Diagnose defaultStyle, printDiagnostic, stdout, + diagnosticToJson, WithUnicode (..), TabSize (..), ) From 0a5ea4120797c8e743ce5137688dd8198c17d22d Mon Sep 17 00:00:00 2001 From: Ellie Hermaszewska Date: Tue, 16 May 2023 13:13:48 +0800 Subject: [PATCH 09/16] Functor Foldable Traversable instances for Annotation --- src/Error/Diagnose/Style.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Error/Diagnose/Style.hs b/src/Error/Diagnose/Style.hs index 5ba6808..e943703 100644 --- a/src/Error/Diagnose/Style.hs +++ b/src/Error/Diagnose/Style.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} -- | -- Module : Error.Diagnose.Style @@ -71,7 +73,7 @@ data Annotation a CodeStyle | -- | Something else, could be provided by the user OtherStyle a - deriving (Functor) + deriving (Functor, Foldable, Traversable) -- | A style is a function which can be applied using 'reAnnotate'. -- From 423b07e6548ebeec3c9fa57cfb67acd5c88d7f4b Mon Sep 17 00:00:00 2001 From: Ellie Hermaszewska Date: Tue, 16 May 2023 13:16:35 +0800 Subject: [PATCH 10/16] Add a couple of tests for user Doc rendering --- test/parsec/Spec.hs | 1 - test/rendering/Spec.hs | 65 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 65 insertions(+), 1 deletion(-) diff --git a/test/parsec/Spec.hs b/test/parsec/Spec.hs index 512fb49..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 #-} diff --git a/test/rendering/Spec.hs b/test/rendering/Spec.hs index c407094..09bd87d 100644 --- a/test/rendering/Spec.hs +++ b/test/rendering/Spec.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ParallelListComp #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} #ifdef USE_AESON import qualified Data.ByteString.Lazy as BS @@ -16,12 +18,17 @@ import Error.Diagnose def, defaultStyle, printDiagnostic, + printDiagnostic', stdout, diagnosticToJson, WithUnicode (..), TabSize (..), ) import System.IO (hPutStrLn) +import Prettyprinter (Doc, annotate, pretty, hsep, indent, vsep) +import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), color, bold, italicized, underlined) +import Data.Traversable (mapAccumL) +import Data.Functor.Compose (Compose(..)) main :: IO () main = do @@ -76,19 +83,77 @@ main = do errorWithBlankAndNormalMarkerInLine, beautifulExample ] + customAnnReports = + [ colorfulReport, + indentedReport + ] 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 WithUnicode (TabSize 4) defaultStyle diag hPutStrLn stdout "\n\nWithout unicode: ----------------------\n" 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) + ,(Position (1, 5) (1, 10) "test.zc", Where 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." + ] + errorNoMarkersNoHints :: Report String errorNoMarkersNoHints = Err From 1df98d31b666e3ecd6522be465973dc8212be83a Mon Sep 17 00:00:00 2001 From: Ellie Hermaszewska Date: Tue, 16 May 2023 13:27:14 +0800 Subject: [PATCH 11/16] Bump version to reflect breaking changes --- diagnose.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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. From 7838253a7a27fa28f821d04c094276e8eb16e4af Mon Sep 17 00:00:00 2001 From: Ellie Hermaszewska Date: Tue, 16 May 2023 14:26:31 +0800 Subject: [PATCH 12/16] Add Eq and Ord instances to Note --- src/Error/Diagnose/Report/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Error/Diagnose/Report/Internal.hs b/src/Error/Diagnose/Report/Internal.hs index f667d0f..8d3568a 100644 --- a/src/Error/Diagnose/Report/Internal.hs +++ b/src/Error/Diagnose/Report/Internal.hs @@ -155,7 +155,7 @@ data Note msg Note msg | -- | A hint, to propose potential fixes or help towards fixing the issue. Hint msg - deriving (Functor, Foldable, Traversable) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) #ifdef USE_AESON instance ToJSON msg => ToJSON (Note msg) where From e62d09c59939127e76ce2a2c033e377467b4c1e0 Mon Sep 17 00:00:00 2001 From: Ellie Hermaszewska Date: Tue, 16 May 2023 15:33:49 +0800 Subject: [PATCH 13/16] Fix nested user strings and add test --- src/Error/Diagnose/Report/Internal.hs | 5 ++-- test/rendering/Spec.hs | 43 +++++++++++++++++++++------ 2 files changed, 37 insertions(+), 11 deletions(-) diff --git a/src/Error/Diagnose/Report/Internal.hs b/src/Error/Diagnose/Report/Internal.hs index 8d3568a..bfd881c 100644 --- a/src/Error/Diagnose/Report/Internal.hs +++ b/src/Error/Diagnose/Report/Internal.hs @@ -53,7 +53,7 @@ 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, (<+>), reAnnotate) -import Prettyprinter.Internal (Doc (..)) +import Prettyprinter.Internal (Doc (..), textSpaces) import Data.Bool (bool) type FileMap = HashMap FilePath (Array Int String) @@ -653,7 +653,8 @@ replaceLinesWith repl (Text _ s) = 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) +-- We need to push the nesting past our line prefix +replaceLinesWith repl (Nest n d) = replaceLinesWith (repl <> pretty (textSpaces n)) 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) diff --git a/test/rendering/Spec.hs b/test/rendering/Spec.hs index 09bd87d..de8b361 100644 --- a/test/rendering/Spec.hs +++ b/test/rendering/Spec.hs @@ -5,12 +5,13 @@ #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, @@ -20,12 +21,11 @@ import Error.Diagnose printDiagnostic, printDiagnostic', stdout, - diagnosticToJson, WithUnicode (..), TabSize (..), ) import System.IO (hPutStrLn) -import Prettyprinter (Doc, annotate, pretty, hsep, indent, vsep) +import Prettyprinter (Doc, annotate, pretty, hsep, indent, vsep, nest) import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), color, bold, italicized, underlined) import Data.Traversable (mapAccumL) import Data.Functor.Compose (Compose(..)) @@ -85,7 +85,8 @@ main = do ] customAnnReports = [ colorfulReport, - indentedReport + indentedReport, + nestingReport ] let diag = HashMap.foldlWithKey' addFile (foldl addReport def reports) files @@ -125,11 +126,10 @@ 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) - ,(Position (1, 5) (1, 10) "test.zc", Where c) + [ (Position (1, 15) (1, 16) "test.zc", Maybe a) + , (Position (1, 11) (1, 12) "test.zc", This b) ] - [] + [Note c] where a = vsep @@ -145,7 +145,8 @@ indentedReport = , "A man in hue, all “hues” in his controlling," , "Which steals men’s eyes and women’s souls amazeth." ] - c = vsep + 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," @@ -154,6 +155,30 @@ indentedReport = , 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] + 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." + ] + errorNoMarkersNoHints :: Report String errorNoMarkersNoHints = Err From 604f083fa1002d7dc251fdbadd1711e0d8593259 Mon Sep 17 00:00:00 2001 From: Ellie Hermaszewska Date: Tue, 16 May 2023 17:14:57 +0800 Subject: [PATCH 14/16] squash warnings --- src/Error/Diagnose/Diagnostic/Internal.hs | 2 -- src/Error/Diagnose/Report/Internal.hs | 2 -- src/Error/Diagnose/Style.hs | 2 -- 3 files changed, 6 deletions(-) diff --git a/src/Error/Diagnose/Diagnostic/Internal.hs b/src/Error/Diagnose/Diagnostic/Internal.hs index d263d1c..605bbe2 100644 --- a/src/Error/Diagnose/Diagnostic/Internal.hs +++ b/src/Error/Diagnose/Diagnostic/Internal.hs @@ -1,6 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/src/Error/Diagnose/Report/Internal.hs b/src/Error/Diagnose/Report/Internal.hs index bfd881c..f782e9c 100644 --- a/src/Error/Diagnose/Report/Internal.hs +++ b/src/Error/Diagnose/Report/Internal.hs @@ -1,7 +1,5 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiWayIf #-} diff --git a/src/Error/Diagnose/Style.hs b/src/Error/Diagnose/Style.hs index e943703..45c67d0 100644 --- a/src/Error/Diagnose/Style.hs +++ b/src/Error/Diagnose/Style.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} -- | From 3a99b70403c84fbd371a91d56283315ed034c2ba Mon Sep 17 00:00:00 2001 From: Ellie Hermaszewska Date: Tue, 16 May 2023 17:16:46 +0800 Subject: [PATCH 15/16] Correct behaviour of Nesting --- src/Error/Diagnose/Report/Internal.hs | 65 ++++++++++++++++----------- test/rendering/Spec.hs | 34 ++++++++++---- 2 files changed, 64 insertions(+), 35 deletions(-) diff --git a/src/Error/Diagnose/Report/Internal.hs b/src/Error/Diagnose/Report/Internal.hs index f782e9c..fba4907 100644 --- a/src/Error/Diagnose/Report/Internal.hs +++ b/src/Error/Diagnose/Report/Internal.hs @@ -50,7 +50,7 @@ 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, (<+>), reAnnotate) +import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>), reAnnotate, SimpleDocStream (..), layoutCompact) import Prettyprinter.Internal (Doc (..), textSpaces) import Data.Bool (bool) @@ -493,7 +493,7 @@ 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 (unicode "| " "│ " withUnicode) @@ -504,12 +504,12 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu then unicode "`- " "╰╸ " withUnicode else unicode "|- " "├╸ " withUnicode ) - <> replaceLinesWith (if isLast then prefix <> " " else prefixWithBar (Just $ markerColor isError marker) <> space) (annotated $ 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_ :: @@ -619,7 +619,7 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn Nothing -> 0 Just col -> widthsBetween bc col - currentPipe = unicode (bool "`" "|" hasSuccessor) (bool "╰" "├" hasSuccessor) withUnicode + currentPipe = unicode (bool "`" "|" hasSuccessor) (bool "╰" "├" hasSuccessor) withUnicode lineChar = unicode '-' '─' withUnicode pointChar = unicode "-" "╸" withUnicode @@ -633,31 +633,42 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn 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 " ") $ annotated $ 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) --- We need to push the nesting past our line prefix -replaceLinesWith repl (Nest n d) = replaceLinesWith (repl <> pretty (textSpaces n)) 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 :: @@ -690,8 +701,8 @@ 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 <+> " ") (annotated $ 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:" diff --git a/test/rendering/Spec.hs b/test/rendering/Spec.hs index de8b361..d3a097d 100644 --- a/test/rendering/Spec.hs +++ b/test/rendering/Spec.hs @@ -25,7 +25,8 @@ import Error.Diagnose TabSize (..), ) import System.IO (hPutStrLn) -import Prettyprinter (Doc, annotate, pretty, hsep, indent, vsep, nest) +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(..)) @@ -162,7 +163,7 @@ nestingReport = (nest 4 $ vsep ["Nest...", "foo", "bar", "baz"]) [ (Position (1, 15) (1, 16) "test.zc", Maybe a) ] - [Note b] + [Note b, Hint c] where a = nest 3 $ @@ -172,12 +173,29 @@ nestingReport = , "'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." - ] + 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 = From df6a33978934306857c5ec80e8927e3b7fdfbd55 Mon Sep 17 00:00:00 2001 From: Ellie Hermaszewska Date: Tue, 30 May 2023 21:19:47 +0800 Subject: [PATCH 16/16] Correct usage example in readme --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index df7820f..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 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).