Mesabloo/diagnose
1
1
Fork 0
mirror of https://github.com/Mesabloo/diagnose.git synced 2024-09-11 19:27:32 +03:00
Code Issues Projects Releases Wiki Activity

Revert "add functionality for Doc messages"

Browse Source 
This reverts commit add174dbc07990ea993902bc9bddd6d5b64a6ca3.
This commit is contained in:
Ellie Hermaszewska 2023-05-16 11:23:43 +08:00
parent 92c36532eb
commit 559babd1be
No known key found for this signature in database
3 changed files with 65 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
src/Error/Diagnose/Diagnostic/Internal.hs
View File

@ -34,8 +34,8 @@ import Data.List (intersperse)
import Error.Diagnose.Report (Report) import Error.Diagnose.Report (Report)
import Error.Diagnose.Report.Internal (FileMap, errorToWarning, prettyReport, warningToError) import Error.Diagnose.Report.Internal (FileMap, errorToWarning, prettyReport, warningToError)
import Error.Diagnose.Style (Annotation, Style) import Error.Diagnose.Style (Annotation, Style)
import Prettyprinter (Doc, Pretty, hardline, unAnnotate, pretty) import Prettyprinter (Doc, Pretty, hardline, unAnnotate)
import Prettyprinter.Render.Terminal (hPutDoc, AnsiStyle) import Prettyprinter.Render.Terminal (hPutDoc)
import System.IO (Handle) import System.IO (Handle)
-- | The data type for diagnostic containing messages of an abstract type. -- | The data type for diagnostic containing messages of an abstract type.
@ -108,25 +108,10 @@ prettyDiagnostic ::
-- | The diagnostic to print. -- | The diagnostic to print.
Diagnostic msg -> Diagnostic msg ->
Doc Annotation Doc Annotation
prettyDiagnostic withUnicode tabSize = prettyDiagnostic withUnicode tabSize (Diagnostic reports file) =
prettyDiagnostic' id withUnicode tabSize . fmap pretty fold . intersperse hardline $ prettyReport file withUnicode tabSize <$> toList reports
{-# INLINE prettyDiagnostic #-} {-# 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'. -- | Prints a 'Diagnostic' onto a specific 'Handle'.
printDiagnostic :: printDiagnostic ::
(MonadIO m, Pretty msg) => (MonadIO m, Pretty msg) =>
@ -143,28 +128,10 @@ printDiagnostic ::
-- | The diagnostic to output. -- | The diagnostic to output.
Diagnostic msg -> Diagnostic msg ->
m () m ()
printDiagnostic handle withUnicode withColors tabSize style = printDiagnostic handle withUnicode withColors tabSize style diag =
printDiagnostic' handle withUnicode tabSize (if withColors then style else const mempty) . fmap pretty liftIO $ hPutDoc handle ((if withColors then style else unAnnotate) $ prettyDiagnostic withUnicode tabSize diag)
{-# INLINE printDiagnostic #-} {-# 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. -- | Inserts a new referenceable file within the diagnostic.
addFile :: addFile ::
Diagnostic msg -> Diagnostic msg ->

112
src/Error/Diagnose/Report/Internal.hs
View File

@ -50,7 +50,7 @@ import Data.String (IsString (fromString))
import qualified Data.Text as Text import qualified Data.Text as Text
import Error.Diagnose.Position import Error.Diagnose.Position
import Error.Diagnose.Style (Annotation (..)) 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 (..)) import Prettyprinter.Internal (Doc (..))
type FileMap = HashMap FilePath (Array Int String) 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. -- | Pretty prints a report to a 'Doc' handling colors.
prettyReport :: prettyReport ::
-- | How to reannotate Diagnose's output Pretty msg =>
(Annotation -> ann) ->
-- | The content of the file the reports are for -- | The content of the file the reports are for
FileMap -> FileMap ->
-- | Should we print paths in unicode? -- | Should we print paths in unicode?
@ -204,9 +203,9 @@ prettyReport ::
-- | The number of spaces each TAB character will span -- | The number of spaces each TAB character will span
Int -> Int ->
-- | The whole report to output -- | The whole report to output
Report (Doc ann) -> Report msg ->
Doc ann Doc Annotation
prettyReport sty fileContent withUnicode tabSize (Report isError code message markers hints) = prettyReport fileContent withUnicode tabSize (Report isError code message markers hints) =
let sortedMarkers = List.sortOn (fst . begin . fst) markers 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 -- 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 = header =
annotate annotate
(sty (KindColor isError)) (KindColor isError)
( lbracket ( lbracket
<> ( if isError <> ( if isError
then "error" then "error"
@ -226,7 +225,7 @@ prettyReport sty fileContent withUnicode tabSize (Report isError code message ma
) )
<> case code of <> case code of
Nothing -> rbracket Nothing -> rbracket
Just code -> space <> code <> rbracket Just code -> space <> pretty code <> rbracket
) )
in {- in {-
A report is of the form: A report is of the form:
@ -241,19 +240,19 @@ prettyReport sty fileContent withUnicode tabSize (Report isError code message ma
(6) -------+ (6) -------+
-} -}
{- (1) -} header <> colon <+> align message {- (1) -} header <> colon <+> align (pretty message)
<> {- (2), (3), (4) -} foldMap (uncurry (prettySubReport sty fileContent withUnicode isError tabSize maxLineNumberLength)) groupedMarkers <> {- (2), (3), (4) -} fold (uncurry (prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength) <$> groupedMarkers)
<> {- (5) -} ( if <> {- (5) -} ( if
| null hints && null markers -> mempty | null hints && null markers -> mempty
| null hints -> 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 <> hardline
<> {- (6) -} ( if null markers && null hints <> {- (6) -} ( if null markers && null hints
then mempty then mempty
else 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 <> hardline
) )
@ -329,6 +328,7 @@ ellipsisPrefix ::
ellipsisPrefix leftLen withUnicode = pad leftLen ' ' mempty <> annotate RuleColor (if withUnicode then space <> "⋮" else "...") ellipsisPrefix leftLen withUnicode = pad leftLen ' ' mempty <> annotate RuleColor (if withUnicode then space <> "⋮" else "...")
groupMarkersPerFile :: groupMarkersPerFile ::
Pretty msg =>
[(Position, Marker msg)] -> [(Position, Marker msg)] ->
[(Bool, [(Position, Marker msg)])] [(Bool, [(Position, Marker msg)])]
groupMarkersPerFile [] = [] groupMarkersPerFile [] = []
@ -352,8 +352,7 @@ groupMarkersPerFile markers =
-- | Prettyprint a sub-report, which is a part of the report spanning across a single file -- | Prettyprint a sub-report, which is a part of the report spanning across a single file
prettySubReport :: prettySubReport ::
-- | How to reannotate Diagnose's output Pretty msg =>
(Annotation -> ann) ->
-- | The content of files in the diagnostics -- | The content of files in the diagnostics
FileMap -> FileMap ->
-- | Is the output done with Unicode characters? -- | Is the output done with Unicode characters?
@ -367,9 +366,9 @@ prettySubReport ::
-- | Is this sub-report the first one in the list? -- | Is this sub-report the first one in the list?
Bool -> Bool ->
-- | The list of line-ordered markers appearing in a single file -- | The list of line-ordered markers appearing in a single file
[(Position, Marker (Doc ann))] -> [(Position, Marker msg)] ->
Doc ann Doc Annotation
prettySubReport sty fileContent withUnicode isError tabSize maxLineNumberLength isFirst markers = prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength isFirst markers =
let (markersPerLine, multilineMarkers) = splitMarkersPerLine markers let (markersPerLine, multilineMarkers) = splitMarkersPerLine markers
-- split the list on whether markers are multiline or not -- 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 RuleColor (if withUnicode then "┼──▶" else "+-->")
) )
<+> annotate FileColor reportFile <+> annotate FileColor reportFile
in {- (2) -} hardline <> reAnnotate sty fileMarker in {- (2) -} hardline <> fileMarker
<> hardline <> hardline
<+> {- (3) -} {- (3) -} reAnnotate sty (pipePrefix maxLineNumberLength withUnicode) <+> {- (3) -} pipePrefix maxLineNumberLength withUnicode
<> {- (4) -} prettyAllLines sty fileContent withUnicode isError tabSize maxLineNumberLength sortedMarkersPerLine multilineMarkers allLineNumbers <> {- (4) -} prettyAllLines fileContent withUnicode isError tabSize maxLineNumberLength sortedMarkersPerLine multilineMarkers allLineNumbers
isThisMarker :: Marker msg -> Bool isThisMarker :: Marker msg -> Bool
isThisMarker (This _) = True isThisMarker (This _) = True
@ -411,30 +410,30 @@ splitMarkersPerLine (m@(Position {..}, _) : ms) =
-- | -- |
prettyAllLines :: prettyAllLines ::
(Annotation -> ann) -> Pretty msg =>
FileMap -> FileMap ->
Bool -> Bool ->
Bool -> Bool ->
-- | The number of spaces each TAB character will span -- | The number of spaces each TAB character will span
Int -> Int ->
Int -> Int ->
[(Int, [(Position, Marker (Doc ann))])] -> [(Int, [(Position, Marker msg)])] ->
[(Position, Marker (Doc ann))] -> [(Position, Marker msg)] ->
[Int] -> [Int] ->
Doc ann Doc Annotation
prettyAllLines sty files withUnicode isError tabSize leftLen inline multiline lineNumbers = prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNumbers =
case lineNumbers of case lineNumbers of
[] -> [] ->
showMultiline True multiline showMultiline True multiline
[l] -> [l] ->
let (ms, doc) = showForLine True l let (ms, doc) = showForLine True l
in doc in doc
<> prettyAllLines sty files withUnicode isError tabSize leftLen inline ms [] <> prettyAllLines files withUnicode isError tabSize leftLen inline ms []
l1 : l2 : ls -> l1 : l2 : ls ->
let (ms, doc) = showForLine False l1 let (ms, doc) = showForLine False l1
in doc in doc
<> (if l2 /= l1 + 1 then hardline <+> reAnnotate sty (dotPrefix leftLen withUnicode) else mempty) <> (if l2 /= l1 + 1 then hardline <+> dotPrefix leftLen withUnicode else mempty)
<> prettyAllLines sty files withUnicode isError tabSize leftLen inline ms (l2 : ls) <> prettyAllLines files withUnicode isError tabSize leftLen inline ms (l2 : ls)
where where
showForLine isLastLine line = showForLine isLastLine line =
{- {-
@ -482,12 +481,12 @@ prettyAllLines sty files withUnicode isError tabSize leftLen inline multiline li
allInlineMarkersInLine' = filter ((/=) Blank . snd) allInlineMarkersInLine allInlineMarkersInLine' = filter ((/=) Blank . snd) allInlineMarkersInLine
allMultilineMarkersSpanningLine' = filter ((/=) Blank . snd) allMultilineMarkersSpanningLine 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, in ( otherMultilines,
hardline hardline
<> {- (1) -} reAnnotate sty (linePrefix leftLen line withUnicode <+> additionalPrefix) <> {- (1) -} linePrefix leftLen line withUnicode <+> additionalPrefix
<> renderedCode <> 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 <> 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 let colorOfFirstMultilineMarker = markerColor isError . snd <$> List.safeHead multiline
-- take the color of the last multiline marker in case we need to add additional bars -- 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 (_, Blank) _ = mempty
showMultilineMarkerMessage (_, marker) isLast = showMultilineMarkerMessage (_, marker) isLast =
annotate (sty (markerColor isError marker)) $ annotate (markerColor isError marker) $
( if isLast && isLastMultiline ( if isLast && isLastMultiline
then if withUnicode then "╰╸ " else "`- " then if withUnicode then "╰╸ " else "`- "
else 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 [] = []
showMultilineMarkerMessages [m] = [showMultilineMarkerMessage m True] showMultilineMarkerMessages [m] = [showMultilineMarkerMessage m True]
@ -516,18 +515,17 @@ prettyAllLines sty files withUnicode isError tabSize leftLen inline multiline li
-- | -- |
getLine_ :: getLine_ ::
(Annotation -> ann) ->
FileMap -> FileMap ->
[(Position, Marker msg)] -> [(Position, Marker msg)] ->
Int -> Int ->
Int -> Int ->
Bool -> Bool ->
(WidthTable, Doc ann) (WidthTable, Doc Annotation)
getLine_ sty files markers line tabSize isError = getLine_ files markers line tabSize isError =
case safeArrayIndex (line - 1) =<< (HashMap.!?) files . file . fst =<< List.safeHead markers of case safeArrayIndex (line - 1) =<< (HashMap.!?) files . file . fst =<< List.safeHead markers of
Nothing -> Nothing ->
( mkWidthTable "", ( mkWidthTable "",
annotate (sty NoLineColor) "<no line>" annotate NoLineColor "<no line>"
) )
Just code -> Just code ->
( mkWidthTable code, ( mkWidthTable code,
@ -542,8 +540,8 @@ getLine_ sty files markers line tabSize isError =
|| (el == line && n < ec) || (el == line && n < ec)
|| (bl < line && el > line) || (bl < line && el > line)
in maybe in maybe
(annotate (sty CodeStyle)) (annotate CodeStyle)
((\m -> annotate (sty . MarkerStyle $ markerColor isError m)) . snd) ((\m -> annotate (MarkerStyle $ markerColor isError m)) . snd)
(List.safeHead colorizingMarkers) (List.safeHead colorizingMarkers)
cdoc cdoc
) )
@ -556,16 +554,16 @@ getLine_ sty files markers line tabSize isError =
mkWidthTable s = listArray (1, length s) (ifTab tabSize wcwidth <$> s) 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 :: Pretty msg => Bool -> Bool -> (Doc Annotation -> Doc Annotation) -> Bool -> Bool -> Int -> WidthTable -> [(Position, Marker msg)] -> Doc Annotation
showAllMarkersInLine _ _ _ _ _ _ _ _ [] = mempty showAllMarkersInLine _ _ _ _ _ _ _ [] = mempty
showAllMarkersInLine sty hasMultilines inSpanOfMultiline colorMultilinePrefix withUnicode isError leftLen widths ms = showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUnicode isError leftLen widths ms =
let maxMarkerColumn = snd $ end $ fst $ List.last $ List.sortOn (snd . end . fst) ms let maxMarkerColumn = snd $ end $ fst $ List.last $ List.sortOn (snd . end . fst) ms
specialPrefix specialPrefix
| inSpanOfMultiline = colorMultilinePrefix (if withUnicode then "│ " else "| ") <> space | inSpanOfMultiline = colorMultilinePrefix (if withUnicode then "│ " else "| ") <> space
| hasMultilines = colorMultilinePrefix " " <> space | hasMultilines = colorMultilinePrefix " " <> space
| otherwise = mempty | otherwise = mempty
in -- get the maximum end column, so that we know when to stop looking for other markers on the same line 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 where
widthAt i = 0 `fromMaybe` safeArrayIndex i widths widthAt i = 0 `fromMaybe` safeArrayIndex i widths
widthsBetween start end = widthsBetween start end =
@ -607,14 +605,14 @@ showAllMarkersInLine sty hasMultilines inSpanOfMultiline colorMultilinePrefix wi
lineStart pipes = lineStart pipes =
let (n, docs) = allColumns 1 $ List.sortOn (snd . begin . fst) pipes let (n, docs) = allColumns 1 $ List.sortOn (snd . begin . fst) pipes
numberOfSpaces = widthsBetween n bc 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 -- the start of the line contains the "dot"-prefix as well as all the pipes for all the still not rendered marker messages
prefix = prefix =
let (pipesBefore, pipesAfter) = List.partition ((< bc) . snd . begin . fst) nubbedPipes 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 -- 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 -- pre-render pipes which are before because they will be shown
lastBeginPosition = snd . begin . fst <$> List.safeLast (List.sortOn (snd . begin . fst) pipesAfter) 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 bc' = bc + lineLen + 2
pipesBeforeMessageStart = List.filter ((< bc') . snd . begin . fst) pipesAfter pipesBeforeMessageStart = List.filter ((< bc') . snd . begin . fst) pipesAfter
-- consider pipes before, as well as pipes which came before the text rectangle bounds -- 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 in -- also pre-render pipes which are before the message text bounds, because they will be shown if the message is on
-- multiple lines -- multiple lines
lineStart pipesBeforeRendered lineStart pipesBeforeRendered
<> annotate (sty (markerColor isError msg)) (currentPipe <> pretty (replicate lineLen lineChar) <> pointChar) <> annotate (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) (replaceLinesWith (hardline <+> lineStart pipesBeforeMessageRendered <+> if List.null pipesBeforeMessageStart then " " else " ") $ pretty $ markerMessage msg)
in hardline <+> prefix <> showMessages specialPrefix pipes lineLen in hardline <+> prefix <> showMessages specialPrefix pipes lineLen
-- WARN: uses the internal of the library -- WARN: uses the internal of the library
@ -691,16 +689,16 @@ markerMessage Blank = undefined
{-# INLINE markerMessage #-} {-# INLINE markerMessage #-}
-- | Pretty prints all hints. -- | Pretty prints all hints.
prettyAllHints :: (Annotation -> ann) -> [Note (Doc ann)] -> Int -> Bool -> Doc ann prettyAllHints :: Pretty msg => [Note msg] -> Int -> Bool -> Doc Annotation
prettyAllHints _ [] _ _ = mempty prettyAllHints [] _ _ = mempty
prettyAllHints sty (h : hs) leftLen withUnicode = prettyAllHints (h : hs) leftLen withUnicode =
{- {-
A hint is composed of: A hint is composed of:
(1) : Hint: <hint message> (1) : Hint: <hint message>
-} -}
let prefix = hardline <+> reAnnotate sty (pipePrefix leftLen withUnicode) let prefix = hardline <+> pipePrefix leftLen withUnicode
in prefix <+> annotate (sty HintColor) (notePrefix h <+> replaceLinesWith (prefix <+> " ") (noteMessage h)) in prefix <+> annotate HintColor (notePrefix h <+> replaceLinesWith (prefix <+> " ") (pretty $ noteMessage h))
<> prettyAllHints sty hs leftLen withUnicode <> prettyAllHints hs leftLen withUnicode
where where
notePrefix (Note _) = "Note:" notePrefix (Note _) = "Note:"
notePrefix (Hint _) = "Hint:" notePrefix (Hint _) = "Hint:"

4
src/Error/Diagnose/Style.hs
View File

@ -15,9 +15,13 @@ module Error.Diagnose.Style
-- * Default style specification -- * Default style specification
defaultStyle, defaultStyle,
-- * Re-exports
reAnnotate,
) )
where where
import Prettyprinter (Doc, reAnnotate)
import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), bold, color, colorDull) import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), bold, color, colorDull)
-- $defining_new_styles -- $defining_new_styles