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

add functionality for Doc messages

Browse Source
This commit is contained in:
Ellie Hermaszewska 2023-05-16 11:11:32 +08:00
parent d06f4c1810
commit 4270c6e320
No known key found for this signature in database
3 changed files with 112 additions and 83 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) import Prettyprinter (Doc, Pretty, hardline, unAnnotate, pretty)
import Prettyprinter.Render.Terminal (hPutDoc) import Prettyprinter.Render.Terminal (hPutDoc, AnsiStyle)
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,10 +108,25 @@ prettyDiagnostic ::
-- | The diagnostic to print. -- | The diagnostic to print.
Diagnostic msg -> Diagnostic msg ->
Doc Annotation Doc Annotation
prettyDiagnostic withUnicode tabSize (Diagnostic reports file) = prettyDiagnostic withUnicode tabSize =
fold . intersperse hardline $ prettyReport file withUnicode tabSize <$> toList reports prettyDiagnostic' id withUnicode tabSize . fmap pretty
{-# 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) =>
@ -128,10 +143,28 @@ printDiagnostic ::
-- | The diagnostic to output. -- | The diagnostic to output.
Diagnostic msg -> Diagnostic msg ->
m () m ()
printDiagnostic handle withUnicode withColors tabSize style diag = printDiagnostic handle withUnicode withColors tabSize style =
liftIO $ hPutDoc handle ((if withColors then style else unAnnotate) $ prettyDiagnostic withUnicode tabSize diag) printDiagnostic' handle withUnicode tabSize (if withColors then style else const mempty) . fmap pretty
{-# 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, (<+>)) import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>), reAnnotate)
import Prettyprinter.Internal (Doc (..)) import Prettyprinter.Internal (Doc (..))
type FileMap = HashMap FilePath (Array Int String) 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. -- | Pretty prints a report to a 'Doc' handling colors.
prettyReport :: prettyReport ::
Pretty msg => -- | How to reannotate Diagnose's output
(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?
@ -203,9 +204,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 msg -> Report (Doc ann) ->
Doc Annotation Doc ann
prettyReport fileContent withUnicode tabSize (Report isError code message markers hints) = prettyReport sty 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
@ -217,7 +218,7 @@ prettyReport fileContent withUnicode tabSize (Report isError code message marker
header = header =
annotate annotate
(KindColor isError) (sty (KindColor isError))
( lbracket ( lbracket
<> ( if isError <> ( if isError
then "error" then "error"
@ -225,7 +226,7 @@ prettyReport fileContent withUnicode tabSize (Report isError code message marker
) )
<> case code of <> case code of
Nothing -> rbracket Nothing -> rbracket
Just code -> space <> pretty code <> rbracket Just code -> space <> code <> rbracket
) )
in {- in {-
A report is of the form: A report is of the form:
@ -240,19 +241,19 @@ prettyReport fileContent withUnicode tabSize (Report isError code message marker
(6) -------+ (6) -------+
-} -}
{- (1) -} header <> colon <+> align (pretty message) {- (1) -} header <> colon <+> align message
<> {- (2), (3), (4) -} fold (uncurry (prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength) <$> groupedMarkers) <> {- (2), (3), (4) -} foldMap (uncurry (prettySubReport sty 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 <+> dotPrefix maxLineNumberLength withUnicode | otherwise -> hardline <+> reAnnotate sty (dotPrefix maxLineNumberLength withUnicode)
) )
<> prettyAllHints hints maxLineNumberLength withUnicode <> prettyAllHints sty hints maxLineNumberLength withUnicode
<> hardline <> hardline
<> {- (6) -} ( if null markers && null hints <> {- (6) -} ( if null markers && null hints
then mempty then mempty
else 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 <> hardline
) )
@ -328,7 +329,6 @@ 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,7 +352,8 @@ 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 ::
Pretty msg => -- | How to reannotate Diagnose's output
(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?
@ -366,9 +367,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 msg)] -> [(Position, Marker (Doc ann))] ->
Doc Annotation Doc ann
prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength isFirst markers = prettySubReport sty 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
@ -390,10 +391,10 @@ prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength isFi
<> annotate RuleColor (if withUnicode then "┼──▶" else "+-->") <> annotate RuleColor (if withUnicode then "┼──▶" else "+-->")
) )
<+> annotate FileColor reportFile <+> annotate FileColor reportFile
in {- (2) -} hardline <> fileMarker in {- (2) -} hardline <> reAnnotate sty fileMarker
<> hardline <> hardline
<+> {- (3) -} pipePrefix maxLineNumberLength withUnicode <+> {- (3) -} {- (3) -} reAnnotate sty (pipePrefix maxLineNumberLength withUnicode)
<> {- (4) -} prettyAllLines fileContent withUnicode isError tabSize maxLineNumberLength sortedMarkersPerLine multilineMarkers allLineNumbers <> {- (4) -} prettyAllLines sty fileContent withUnicode isError tabSize maxLineNumberLength sortedMarkersPerLine multilineMarkers allLineNumbers
isThisMarker :: Marker msg -> Bool isThisMarker :: Marker msg -> Bool
isThisMarker (This _) = True isThisMarker (This _) = True
@ -410,30 +411,30 @@ splitMarkersPerLine (m@(Position {..}, _) : ms) =
-- | -- |
prettyAllLines :: prettyAllLines ::
Pretty msg => (Annotation -> ann) ->
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 msg)])] -> [(Int, [(Position, Marker (Doc ann))])] ->
[(Position, Marker msg)] -> [(Position, Marker (Doc ann))] ->
[Int] -> [Int] ->
Doc Annotation Doc ann
prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNumbers = prettyAllLines sty 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 files withUnicode isError tabSize leftLen inline ms [] <> prettyAllLines sty 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 <+> dotPrefix leftLen withUnicode else mempty) <> (if l2 /= l1 + 1 then hardline <+> reAnnotate sty (dotPrefix leftLen withUnicode) else mempty)
<> prettyAllLines files withUnicode isError tabSize leftLen inline ms (l2 : ls) <> prettyAllLines sty files withUnicode isError tabSize leftLen inline ms (l2 : ls)
where where
showForLine isLastLine line = showForLine isLastLine line =
{- {-
@ -481,12 +482,12 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu
allInlineMarkersInLine' = filter ((/=) Blank . snd) allInlineMarkersInLine allInlineMarkersInLine' = filter ((/=) Blank . snd) allInlineMarkersInLine
allMultilineMarkersSpanningLine' = filter ((/=) Blank . snd) allMultilineMarkersSpanningLine 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, in ( otherMultilines,
hardline hardline
<> {- (1) -} linePrefix leftLen line withUnicode <+> additionalPrefix <> {- (1) -} reAnnotate sty (linePrefix leftLen line withUnicode <+> additionalPrefix)
<> renderedCode <> 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 <> 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 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 = 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 (_, Blank) _ = mempty
showMultilineMarkerMessage (_, marker) isLast = showMultilineMarkerMessage (_, marker) isLast =
annotate (markerColor isError marker) $ annotate (sty (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) (pretty $ markerMessage marker) <> replaceLinesWith (if isLast then prefix <> " " else prefixWithBar (Just $ markerColor isError marker) <> space) (markerMessage marker)
showMultilineMarkerMessages [] = [] showMultilineMarkerMessages [] = []
showMultilineMarkerMessages [m] = [showMultilineMarkerMessage m True] showMultilineMarkerMessages [m] = [showMultilineMarkerMessage m True]
@ -515,17 +516,18 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu
-- | -- |
getLine_ :: getLine_ ::
(Annotation -> ann) ->
FileMap -> FileMap ->
[(Position, Marker msg)] -> [(Position, Marker msg)] ->
Int -> Int ->
Int -> Int ->
Bool -> Bool ->
(WidthTable, Doc Annotation) (WidthTable, Doc ann)
getLine_ files markers line tabSize isError = getLine_ sty 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 NoLineColor "<no line>" annotate (sty NoLineColor) "<no line>"
) )
Just code -> Just code ->
( mkWidthTable code, ( mkWidthTable code,
@ -540,8 +542,8 @@ getLine_ 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 CodeStyle) (annotate (sty CodeStyle))
((\m -> annotate (MarkerStyle $ markerColor isError m)) . snd) ((\m -> annotate (sty . MarkerStyle $ markerColor isError m)) . snd)
(List.safeHead colorizingMarkers) (List.safeHead colorizingMarkers)
cdoc cdoc
) )
@ -554,16 +556,16 @@ getLine_ 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 :: Pretty msg => Bool -> Bool -> (Doc Annotation -> Doc Annotation) -> Bool -> Bool -> Int -> WidthTable -> [(Position, Marker msg)] -> Doc Annotation showAllMarkersInLine :: (Annotation -> ann) -> Bool -> Bool -> (Doc Annotation -> Doc Annotation) -> Bool -> Bool -> Int -> WidthTable -> [(Position, Marker (Doc ann))] -> Doc ann
showAllMarkersInLine _ _ _ _ _ _ _ [] = mempty showAllMarkersInLine _ _ _ _ _ _ _ _ [] = mempty
showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUnicode isError leftLen widths ms = showAllMarkersInLine sty 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 <+> 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 where
widthAt i = 0 `fromMaybe` safeArrayIndex i widths widthAt i = 0 `fromMaybe` safeArrayIndex i widths
widthsBetween start end = widthsBetween start end =
@ -605,14 +607,14 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn
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 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 -- 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 (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 -- 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)
@ -634,13 +636,13 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn
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 (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 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 (markerColor isError msg) (currentPipe <> pretty (replicate lineLen lineChar) <> pointChar) <> annotate (sty (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)) (replaceLinesWith (hardline <+> lineStart pipesBeforeMessageRendered <+> if List.null pipesBeforeMessageStart then " " else " ") $ 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
@ -689,16 +691,16 @@ markerMessage Blank = undefined
{-# INLINE markerMessage #-} {-# INLINE markerMessage #-}
-- | Pretty prints all hints. -- | Pretty prints all hints.
prettyAllHints :: Pretty msg => [Note msg] -> Int -> Bool -> Doc Annotation prettyAllHints :: (Annotation -> ann) -> [Note (Doc ann)] -> Int -> Bool -> Doc ann
prettyAllHints [] _ _ = mempty prettyAllHints _ [] _ _ = mempty
prettyAllHints (h : hs) leftLen withUnicode = prettyAllHints sty (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 <+> pipePrefix leftLen withUnicode let prefix = hardline <+> reAnnotate sty (pipePrefix leftLen withUnicode)
in prefix <+> annotate HintColor (notePrefix h <+> replaceLinesWith (prefix <+> " ") (pretty $ noteMessage h)) in prefix <+> annotate (sty HintColor) (notePrefix h <+> replaceLinesWith (prefix <+> " ") (noteMessage h))
<> prettyAllHints hs leftLen withUnicode <> prettyAllHints sty hs leftLen withUnicode
where where
notePrefix (Note _) = "Note:" notePrefix (Note _) = "Note:"
notePrefix (Hint _) = "Hint:" notePrefix (Hint _) = "Hint:"

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

@ -13,13 +13,9 @@ 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
@ -75,7 +71,7 @@ data Annotation
-- --
-- It transforms a 'Doc'ument containing 'Annotation's into a 'Doc'ument containing -- It transforms a 'Doc'ument containing 'Annotation's into a 'Doc'ument containing
-- color information. -- 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 @[error]@/@[warning]@ at the top is colored in red for errors and yellow for warnings
-- * The code is output in normal white -- * The code is output in normal white
defaultStyle :: Style defaultStyle :: Style
defaultStyle = reAnnotate style defaultStyle = \case
where ThisColor isError -> color if isError then Red else Yellow
style = \case MaybeColor -> color Magenta
ThisColor isError -> color if isError then Red else Yellow WhereColor -> colorDull Blue
MaybeColor -> color Magenta HintColor -> color Cyan
WhereColor -> colorDull Blue FileColor -> bold <> colorDull Green
HintColor -> color Cyan RuleColor -> bold <> color Black
FileColor -> bold <> colorDull Green KindColor isError -> bold <> defaultStyle (ThisColor isError)
RuleColor -> bold <> color Black NoLineColor -> bold <> colorDull Magenta
KindColor isError -> bold <> style (ThisColor isError) MarkerStyle st ->
NoLineColor -> bold <> colorDull Magenta let ann = defaultStyle st
MarkerStyle st -> in if ann == defaultStyle CodeStyle
let ann = style st then ann
in if ann == style CodeStyle else bold <> ann
then ann CodeStyle -> color White
else bold <> ann
CodeStyle -> color White