Mesabloo/diagnose
1
1
Fork 0
mirror of https://github.com/Mesabloo/diagnose.git synced 2024-08-16 23:00:47 +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.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 ->

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 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 "<no line>"
annotate (sty NoLineColor) "<no line>"
)
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: <hint message>
-}
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:"

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

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