From 9079d9df3eaea621d56a843d01b47e714f956f16 Mon Sep 17 00:00:00 2001 From: Ruifeng Xie Date: Sat, 3 Sep 2022 15:06:16 +0800 Subject: [PATCH 01/10] duplicate ariadne for codespan-reporting --- diagnose-codespan-reporting/README.md | 5 + .../diagnose-codespan-reporting.cabal | 50 ++ diagnose-codespan-reporting/package.yaml | 46 ++ .../src/Data/List/Safe.hs | 35 ++ .../Diagnose/Layout/CodeSpanReporting.hs | 587 ++++++++++++++++++ hie.yaml | 2 + stack.yaml | 3 +- 7 files changed, 727 insertions(+), 1 deletion(-) create mode 100644 diagnose-codespan-reporting/README.md create mode 100644 diagnose-codespan-reporting/diagnose-codespan-reporting.cabal create mode 100644 diagnose-codespan-reporting/package.yaml create mode 100644 diagnose-codespan-reporting/src/Data/List/Safe.hs create mode 100644 diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs diff --git a/diagnose-codespan-reporting/README.md b/diagnose-codespan-reporting/README.md new file mode 100644 index 0000000..12c366b --- /dev/null +++ b/diagnose-codespan-reporting/README.md @@ -0,0 +1,5 @@ +# `codespan-reporting` layout for Diagnose + +This is an implementation of a custom layout for Diagnose, heavily inspired by [`codespan-reporting`](https://github.com/brendanzab/codespan). + +TODO: add example rendering diff --git a/diagnose-codespan-reporting/diagnose-codespan-reporting.cabal b/diagnose-codespan-reporting/diagnose-codespan-reporting.cabal new file mode 100644 index 0000000..edb2ede --- /dev/null +++ b/diagnose-codespan-reporting/diagnose-codespan-reporting.cabal @@ -0,0 +1,50 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: diagnose-codespan-reporting +version: 1.0.0 +synopsis: codespan-reporting-like rendering for Diagnose. +description: This package simply provides an codespan-reporting-like layout for diagnostic rendering. +category: Error Reporting +homepage: https://github.com/mesabloo/diagnose#readme +bug-reports: https://github.com/mesabloo/diagnose/issues +author: Ghilain Bergeron +maintainer: Ghilain Bergeron +copyright: 2021-2022 Ghilain Bergeron +license: BSD3 +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/mesabloo/diagnose + +library + exposed-modules: + Error.Diagnose.Layout.CodeSpanReporting + other-modules: + Data.List.Safe + Paths_diagnose_codespan_reporting + hs-source-dirs: + src + default-extensions: + OverloadedStrings + LambdaCase + BlockArguments + ghc-options: -Wall -Wextra + build-depends: + array ==0.5.* + , base >=4.7 && <5 + , data-default >=0.7 && <1 + , diagnose >=3.0.0 + , hashable >=1.3 && <2 + , prettyprinter >=1.7.0 && <2 + , prettyprinter-ansi-terminal >=1.1.0 && <2 + , text >=1.0.0.0 && <=2.0 + , unordered-containers ==0.2.* + , wcwidth >=0.0.1 && <1 + default-language: Haskell2010 diff --git a/diagnose-codespan-reporting/package.yaml b/diagnose-codespan-reporting/package.yaml new file mode 100644 index 0000000..6aa82c8 --- /dev/null +++ b/diagnose-codespan-reporting/package.yaml @@ -0,0 +1,46 @@ +name: diagnose-codespan-reporting +version: 1.0.0 +github: "mesabloo/diagnose" +license: BSD3 +author: "Ghilain Bergeron" +copyright: "2021-2022 Ghilain Bergeron" +category: "Error Reporting" + +dependencies: +- base >= 4.7 && < 5 +- diagnose >=3.0.0 +- array >= 0.5 && < 0.6 +- data-default >= 0.7 && < 1 +- hashable >= 1.3 && < 2 +- prettyprinter >= 1.7.0 && < 2 +- prettyprinter-ansi-terminal >= 1.1.0 && < 2 +- unordered-containers >= 0.2 && < 0.3 +- wcwidth >= 0.0.1 && <1 +- text >= 1.0.0.0 && <= 2.0 +# ^^^ This is unfortunately required, but as 'prettyprinter' already depends on it, it will already have been fetched +# into the local cache anyway. + +default-extensions: +- OverloadedStrings +- LambdaCase +- BlockArguments + +library: + source-dirs: src + exposed-modules: + - Error.Diagnose.Layout.CodeSpanReporting + +ghc-options: +- -Wall +- -Wextra +# - -Wmissing-local-signatures +# - -Wmonomorphism-restriction + +extra-source-files: +- README.md + +# This is put at the end for convenience. +synopsis: codespan-reporting-like rendering for Diagnose. + +description: | + This package simply provides an codespan-reporting-like layout for diagnostic rendering. diff --git a/diagnose-codespan-reporting/src/Data/List/Safe.hs b/diagnose-codespan-reporting/src/Data/List/Safe.hs new file mode 100644 index 0000000..4af54d2 --- /dev/null +++ b/diagnose-codespan-reporting/src/Data/List/Safe.hs @@ -0,0 +1,35 @@ +module Data.List.Safe where + +import Data.Bifunctor (first) + + +-- | Analogous to 'Data.List.last', but returns 'Nothing' on an empty list, instead of throwing an error. +safeLast :: [a] -> Maybe a +safeLast [] = Nothing +safeLast l = Just $ last l + +-- | Analogous to `Data.List.head`, but returns 'Nothing' in case of an empty list. +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x : _) = Just x + +-- | Analogous tu 'Data.List.!!', but does not throw an error on missing index. +safeIndex :: Int -> [a] -> Maybe a +safeIndex _ [] = Nothing +safeIndex 0 (x : _) = Just x +safeIndex n (_ : xs) + | n < 0 = Nothing + | otherwise = safeIndex (n - 1) xs + +-- | Safely deconstructs a list from the end. +-- +-- More efficient than @(init x, last x)@ +safeUnsnoc :: [a] -> Maybe ([a], a) +safeUnsnoc [] = Nothing +safeUnsnoc [x] = Just ([], x) +safeUnsnoc (x : xs) = first (x :) <$> safeUnsnoc xs + +-- | Safely deconstructs a list from the beginning, returning 'Nothing' if the list is empty. +safeUncons :: [a] -> Maybe (a, [a]) +safeUncons [] = Nothing +safeUncons (x : xs) = Just (x, xs) diff --git a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs new file mode 100644 index 0000000..5718a92 --- /dev/null +++ b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs @@ -0,0 +1,587 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module Error.Diagnose.Layout.CodeSpanReporting (codespanReportingLayout) where + +import qualified Data.Array.IArray as Array +import Data.Array.Unboxed (IArray, Ix, UArray, listArray, (!)) +import Data.Bifunctor (bimap, first, second) +import Data.Char.WCWidth (wcwidth) +import Data.Default (def) +import Data.Foldable (fold) +import Data.Function (on) +import Data.Functor ((<&>)) +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as HashMap +import Data.List (intersperse) +import qualified Data.List as List +import qualified Data.List.Safe as List +import Data.Maybe (fromMaybe) +import Data.Ord (Down (..)) +import qualified Data.Text as Text +import Error.Diagnose.Diagnostic (filesOf, reportsOf) +import Error.Diagnose.Layout (FileMap, Layout) +import Error.Diagnose.Position (Position (..)) +import Error.Diagnose.Report (Marker (..), Note (..), Report (..)) +import Error.Diagnose.Style (Annotation (..)) +import Prettyprinter (Doc, Pretty, align, annotate, colon, hardline, lbracket, pretty, rbracket, space, width, (<+>)) +import Prettyprinter.Internal.Type (Doc (..)) + +-- | Pretty prints a 'Diagnostic' into a 'Doc'ument that can be output using 'hPutDoc'. +-- +-- Colors are put by default. +-- If you do not want these, just 'unAnnotate' the resulting document like so: +-- +-- >>> let doc = unAnnotate (prettyDiagnostic withUnicode tabSize diagnostic) +-- +-- Changing the style is also rather easy: +-- +-- >>> let myCustomStyle :: Style = _ +-- >>> let doc = myCustomStyle (prettyDiagnostic withUnicode tabSize diagnostic) +codespanReportingLayout :: Layout msg +codespanReportingLayout withUnicode tabSize diag = + fold . intersperse hardline $ prettyReport (filesOf diag) withUnicode tabSize <$> reportsOf diag +{-# INLINE codespanReportingLayout #-} + +-------------------------------------- +------------- INTERNAL --------------- +-------------------------------------- + +type WidthTable = UArray Int Int + +-- | Pretty prints a report to a 'Doc' handling colors. +prettyReport :: + Pretty msg => + -- | The content of the file the reports are for + FileMap -> + -- | Should we print paths in unicode? + Bool -> + -- | The number of spaces each TAB character will span + Int -> + -- | The whole report to output + Report msg -> + Doc Annotation +prettyReport fileContent withUnicode tabSize (Warn code message markers hints) = + prettyReport' fileContent withUnicode tabSize False code message markers hints +prettyReport fileContent withUnicode tabSize (Err code message markers hints) = + prettyReport' fileContent withUnicode tabSize True code message markers hints + +prettyReport' :: + Pretty msg => + FileMap -> + Bool -> + Int -> + Bool -> + Maybe msg -> + msg -> + [(Position, Marker msg)] -> + [Note msg] -> + Doc Annotation +prettyReport' fileContent withUnicode tabSize 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 + + groupedMarkers = groupMarkersPerFile sortedMarkers + -- group markers by the file they appear in, and put `This` markers at the top of the report + + maxLineNumberLength = maybe 3 (max 3 . length . show . fst . end . fst) $ List.safeLast markers + -- if there are no markers, then default to 3, else get the maximum between 3 and the length of the last marker + + header = + annotate + (KindColor isError) + ( lbracket + <> ( if isError + then "error" + else "warning" + ) + <> case code of + Nothing -> rbracket + Just code -> space <> pretty code <> rbracket + ) + in {- + A report is of the form: + (1) [error|warning]: + (2) +--> + (3) : + (4) | + : + : + (5) : + : + (6) -------+ + -} + + {- (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 <+> dotPrefix maxLineNumberLength withUnicode + ) + <> prettyAllHints 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 "+") + <> hardline + ) + +------------------------------------------------------------------------------------- +----- INTERNAL STUFF ---------------------------------------------------------------- +------------------------------------------------------------------------------------- + +-- | Inserts a given number of character after a 'Doc'ument. +pad :: Int -> Char -> Doc ann -> Doc ann +pad n c d = width d \w -> pretty $ replicate (n - w) c + +-- | Creates a "dot"-prefix for a report line where there is no code. +-- +-- Pretty printing yields those results: +-- +-- [with unicode] "@␣␣␣␣␣•␣@" +-- [without unicode] "@␣␣␣␣␣:␣@" +dotPrefix :: + -- | The length of the left space before the bullet. + Int -> + -- | Whether to print with unicode characters or not. + Bool -> + Doc Annotation +dotPrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (if withUnicode then "•" else ":") +{-# INLINE dotPrefix #-} + +-- | Creates a "pipe"-prefix for a report line where there is no code. +-- +-- Pretty printing yields those results: +-- +-- [with unicode] "@␣␣␣␣␣│␣@" +-- [without unicode] "@␣␣␣␣␣|␣@" +pipePrefix :: + -- | The length of the left space before the pipe. + Int -> + -- | Whether to print with unicode characters or not. + Bool -> + Doc Annotation +pipePrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (if withUnicode then "│" else "|") +{-# INLINE pipePrefix #-} + +-- | Creates a line-prefix for a report line containing source code +-- +-- Pretty printing yields those results: +-- +-- [with unicode] "@␣␣␣3␣│␣@" +-- [without unicode] "@␣␣␣3␣|␣@" +-- +-- Results may be different, depending on the length of the line number. +linePrefix :: + -- | The length of the amount of space to span before the vertical bar. + Int -> + -- | The line number to show. + Int -> + -- | Whether to use unicode characters or not. + Bool -> + Doc Annotation +linePrefix leftLen lineNo withUnicode = + let lineNoLen = length (show lineNo) + in annotate RuleColor $ mempty <+> pad (leftLen - lineNoLen) ' ' mempty <> pretty lineNo <+> if withUnicode then "│" else "|" +{-# INLINE linePrefix #-} + +-- | Creates an ellipsis-prefix, when some line numbers are not consecutive. +-- +-- Pretty printing yields those results: +-- +-- [with unicode] "@␣␣␣␣␣⋮␣@" +-- [without unicode] "@␣␣␣␣...@" +ellipsisPrefix :: + Int -> + Bool -> + Doc Annotation +ellipsisPrefix leftLen withUnicode = pad leftLen ' ' mempty <> annotate RuleColor (if withUnicode then space <> "⋮" else "...") + +groupMarkersPerFile :: + Pretty msg => + [(Position, Marker msg)] -> + [(Bool, [(Position, Marker msg)])] +groupMarkersPerFile [] = [] +groupMarkersPerFile markers = + let markersPerFile = List.foldl' (HashMap.unionWith (<>)) mempty $ markers <&> \tup@(p, _) -> HashMap.singleton (file p) [tup] + in -- put all markers on the same file together + -- NOTE: it's a shame that `HashMap.unionsWith f = foldl' (HashMap.unionWith f) mempty` does not exist + + onlyFirstToTrue $ putThisMarkersAtTop $ HashMap.elems markersPerFile + where + onlyFirstToTrue = go True [] + + go _ acc [] = reverse acc + go t acc (x : xs) = go False ((t, x) : acc) xs + + putThisMarkersAtTop = List.sortBy \ms1 ms2 -> + if + | any isThisMarker (snd <$> ms1) -> LT + | any isThisMarker (snd <$> ms2) -> GT + | otherwise -> EQ + +-- | Prettyprint a sub-report, which is a part of the report spanning across a single file +prettySubReport :: + Pretty msg => + -- | The content of files in the diagnostics + FileMap -> + -- | Is the output done with Unicode characters? + Bool -> + -- | Is the current report an error report? + Bool -> + -- | The number of spaces each TAB character will span + Int -> + -- | The size of the biggest line number + Int -> + -- | Is this sub-report the first one in the list? + Bool -> + -- | The list of line-ordered markers appearing in a single file + [(Position, Marker msg)] -> + Doc Annotation +prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength isFirst markers = + let (markersPerLine, multilineMarkers) = splitMarkersPerLine markers + -- split the list on whether markers are multiline or not + + sortedMarkersPerLine = {- second (List.sortOn (first $ snd . begin)) <$> -} List.sortOn fst (HashMap.toList markersPerLine) + + reportFile = maybe (pretty @Position def) (pretty . fst) $ List.safeHead (List.sortOn (Down . snd) markers) + -- the reported file is the file of the first 'This' marker (only one must be present) + + allLineNumbers = List.sort $ List.nub $ (fst <$> sortedMarkersPerLine) <> (multilineMarkers >>= \(Position (bl, _) (el, _) _, _) -> [bl .. el]) + + fileMarker = + ( if isFirst + then + space <> pad maxLineNumberLength ' ' mempty + <+> annotate RuleColor (if withUnicode then "╭──▶" else "+-->") + else + space <> dotPrefix maxLineNumberLength withUnicode <> hardline + <> annotate RuleColor (pad (maxLineNumberLength + 2) (if withUnicode then '─' else '-') mempty) + <> annotate RuleColor (if withUnicode then "┼──▶" else "+-->") + ) + <+> annotate FileColor reportFile + in {- (2) -} hardline <> fileMarker + <> hardline + <+> {- (3) -} pipePrefix maxLineNumberLength withUnicode + <> {- (4) -} prettyAllLines fileContent withUnicode isError tabSize maxLineNumberLength sortedMarkersPerLine multilineMarkers allLineNumbers + +isThisMarker :: Marker msg -> Bool +isThisMarker (This _) = True +isThisMarker _ = False + +-- | +splitMarkersPerLine :: [(Position, Marker msg)] -> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)]) +splitMarkersPerLine [] = (mempty, mempty) +splitMarkersPerLine (m@(Position {..}, _) : ms) = + let (bl, _) = begin + (el, _) = end + in (if bl == el then first (HashMap.insertWith (<>) bl [m]) else second (m :)) + (splitMarkersPerLine 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] -> + 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 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) + where + showForLine isLastLine line = + {- + A line of code is composed of: + (1) | + (2) : + (3) : + + Multline markers may also take additional space (2 characters) on the right of the bar + -} + let allInlineMarkersInLine = snd =<< filter ((==) line . fst) inline + + allMultilineMarkersInLine = flip filter multiline \(Position (bl, _) (el, _) _, _) -> bl == line || el == line + + allMultilineMarkersSpanningLine = flip filter multiline \(Position (bl, _) (el, _) _, _) -> bl < line && el > line + + inSpanOfMultiline = flip any multiline \(Position (bl, _) (el, _) _, _) -> bl <= line && el >= line + + colorOfFirstMultilineMarker = maybe id (annotate . markerColor isError . snd) (List.safeHead $ allMultilineMarkersInLine <> allMultilineMarkersSpanningLine) + -- take the first multiline marker to color the entire line, if there is one + + (multilineEndingOnLine, otherMultilines) = flip List.partition multiline \(Position _ (el, _) _, _) -> el == line + + !additionalPrefix = case allMultilineMarkersInLine of + [] -> + if not $ null multiline + then + if not $ null allMultilineMarkersSpanningLine + then colorOfFirstMultilineMarker if withUnicode then "│ " else "| " + 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 ">") + <> space + + -- we need to remove all blank markers because they are irrelevant to the display + allInlineMarkersInLine' = filter ((/=) Blank . snd) allInlineMarkersInLine + allMultilineMarkersSpanningLine' = filter ((/=) Blank . snd) allMultilineMarkersSpanningLine + + (widths, renderedCode) = getLine_ files (allInlineMarkersInLine <> allMultilineMarkersInLine <> allMultilineMarkersSpanningLine') line tabSize isError + in ( otherMultilines, + hardline + <> {- (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 + ) + + showMultiline _ [] = mempty + showMultiline isLastMultiline 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 + + prefix = hardline <+> dotPrefix leftLen withUnicode <> space + + prefixWithBar color = prefix <> maybe id annotate color (if withUnicode then "│ " else "| ") + + showMultilineMarkerMessage (_, Blank) _ = mempty + showMultilineMarkerMessage (_, marker) isLast = + 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) (pretty $ 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) + +-- | +getLine_ :: + FileMap -> + [(Position, Marker msg)] -> + Int -> + Int -> + Bool -> + (WidthTable, Doc Annotation) +getLine_ files markers line tabSize isError = + case safeArrayIndex (line - 1) =<< (HashMap.!?) files . file . fst =<< List.safeHead markers of + Nothing -> + ( mkWidthTable "", + annotate NoLineColor "" + ) + Just code -> + ( mkWidthTable code, + flip foldMap (zip [1 ..] code) \(n, c) -> + let cdoc = ifTab (pretty (replicate tabSize ' ')) pretty c + colorizingMarkers = flip filter markers \case + (Position (bl, bc) (el, ec) _, _) + | bl == el -> + n >= bc && n < ec + | otherwise -> + (bl == line && n >= bc) + || (el == line && n < ec) + || (bl < line && el > line) + in maybe + (annotate CodeStyle) + ((\m -> annotate (MarkerStyle $ markerColor isError m)) . snd) + (List.safeHead colorizingMarkers) + cdoc + ) + where + ifTab :: a -> (Char -> a) -> Char -> a + ifTab a _ '\t' = a + ifTab _ f c = f c + + mkWidthTable :: String -> WidthTable + 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 = + 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) + where + widthAt i = 0 `fromMaybe` safeArrayIndex i widths + widthsBetween start end = + sum $ take (end - start) $ drop (start - 1) $ Array.elems widths + + showMarkers n lineLen + | n > lineLen = mempty -- reached the end of the line + | otherwise = + let allMarkers = flip filter ms \(Position (_, bc) (_, ec) _, mark) -> mark /= Blank && n >= bc && n < ec + in -- only consider markers which span onto the current column + case allMarkers of + [] -> fold (replicate (widthAt n) space) <> showMarkers (n + 1) lineLen + (Position {..}, marker) : _ -> + 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 "-") + ) + <> showMarkers (n + 1) lineLen + + showMessages specialPrefix ms lineLen = case List.safeUncons ms of + Nothing -> mempty -- no more messages to show + Just ((Position b@(_, bc) _ _, msg), pipes) -> + let filteredPipes = filter (uncurry (&&) . bimap ((/= b) . begin) (/= Blank)) pipes + -- record only the pipes corresponding to markers on different starting positions + nubbedPipes = List.nubBy ((==) `on` (begin . fst)) filteredPipes + -- and then remove all duplicates + + allColumns _ [] = (1, []) + allColumns n ms@((Position (_, bc) _ _, col) : ms') + | n == bc = bimap (+ 1) (col :) (allColumns (n + 1) ms') + | n < bc = bimap (+ 1) (replicate (widthAt n) space <>) (allColumns (n + 1) ms) + | otherwise = bimap (+ 1) (replicate (widthAt n) space <>) (allColumns (n + 1) ms') + -- transform the list of remaining markers into a single document line + + hasSuccessor = length filteredPipes /= length pipes + + 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 ' ') + -- 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 "|") + -- pre-render pipes which are before because they will be shown + + lastBeginPosition = snd . begin . fst <$> List.safeLast (List.sortOn (snd . begin . fst) pipesAfter) + + lineLen = case lastBeginPosition of + Nothing -> 0 + Just col -> widthsBetween bc col + + currentPipe = + if + | withUnicode && hasSuccessor -> "├" + | withUnicode -> "╰" + | hasSuccessor -> "|" + | otherwise -> "`" + + lineChar = if withUnicode then '─' else '-' + pointChar = if withUnicode then "╸" else "-" + + 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 "|") + 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) + in hardline <+> prefix <> showMessages specialPrefix pipes lineLen + +-- WARN: uses the internal of the library 'prettyprinter' +-- +-- DO NOT use a wildcard here, in case the internal API exposes one more constructor + +-- | +replaceLinesWith :: Doc ann -> Doc ann -> Doc ann +replaceLinesWith repl Line = repl +replaceLinesWith _ Fail = Fail +replaceLinesWith _ Empty = Empty +replaceLinesWith _ (Char c) = Char c +replaceLinesWith repl (Text _ s) = + let lines = Text.split (== '\n') s <&> \txt -> Text (Text.length txt) txt + in mconcat (List.intersperse repl lines) +replaceLinesWith repl (FlatAlt f d) = FlatAlt (replaceLinesWith repl f) (replaceLinesWith repl d) +replaceLinesWith repl (Cat c d) = Cat (replaceLinesWith repl c) (replaceLinesWith repl d) +replaceLinesWith repl (Nest n d) = Nest n (replaceLinesWith repl d) +replaceLinesWith repl (Union c d) = Union (replaceLinesWith repl c) (replaceLinesWith repl d) +replaceLinesWith repl (Column f) = Column (replaceLinesWith repl . f) +replaceLinesWith repl (Nesting f) = Nesting (replaceLinesWith repl . f) +replaceLinesWith repl (Annotated ann doc) = Annotated ann (replaceLinesWith repl doc) +replaceLinesWith repl (WithPageWidth f) = WithPageWidth (replaceLinesWith repl . f) + +-- | Extracts the color of a marker as a 'Doc' coloring function. +markerColor :: + -- | Whether the marker is in an error context or not. + -- This really makes a difference for a 'This' marker. + Bool -> + -- | The marker to extract the color from. + Marker msg -> + -- | A function used to color a 'Doc'. + Annotation +markerColor isError (This _) = ThisColor isError +markerColor _ (Where _) = WhereColor +markerColor _ (Maybe _) = MaybeColor +markerColor _ Blank = CodeStyle -- we take the same color as the code, for it to be invisible +{-# INLINE markerColor #-} + +-- | Retrieves the message held by a marker. +markerMessage :: Marker msg -> msg +markerMessage (This m) = m +markerMessage (Where m) = m +markerMessage (Maybe m) = m +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 = + {- + 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 + where + notePrefix (Note _) = "Note:" + notePrefix (Hint _) = "Hint:" + + noteMessage (Note msg) = msg + noteMessage (Hint msg) = msg + +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 diff --git a/hie.yaml b/hie.yaml index 7f4db98..ffed630 100644 --- a/hie.yaml +++ b/hie.yaml @@ -8,6 +8,8 @@ cradle: component: "diagnose-gcc:lib" - path: "./diagnose-typescript/src" component: "diagnose-typescript:lib" + - path: "./diagnose-codespan-reporting/src" + component: "diagnose-codespan-reporting:lib" - path: "./test/rendering" component: "diagnose-tests:test:diagnose-rendering-tests" - path: "./test/megaparsec" diff --git a/stack.yaml b/stack.yaml index 8aed682..c42c90b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -29,11 +29,12 @@ resolver: lts-18.28 # - auto-update # - wai packages: +- . - diagnose-core - diagnose-ariadne - diagnose-gcc - diagnose-typescript -- . +- diagnose-codespan-reporting # Dependency packages to be pulled from upstream that are not in the resolver. # These entries can reference officially published versions as well as # forks / in-progress versions pinned to a git hash. For example: From a887b0b611a76ea379e89a83db19145b475cb91d Mon Sep 17 00:00:00 2001 From: Ruifeng Xie Date: Tue, 13 Sep 2022 19:59:05 +0800 Subject: [PATCH 02/10] finish prototype of codespan-reporting style --- diagnose-codespan-reporting/design.txt | 38 ++ .../diagnose-codespan-reporting.cabal | 2 + .../Diagnose/Layout/CodeSpanReporting.hs | 192 +++++---- .../Layout/CodeSpanReporting/Config.hs | 92 +++++ .../Layout/CodeSpanReporting/Render.hs | 374 ++++++++++++++++++ 5 files changed, 616 insertions(+), 82 deletions(-) create mode 100644 diagnose-codespan-reporting/design.txt create mode 100644 diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Config.hs create mode 100644 diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs diff --git a/diagnose-codespan-reporting/design.txt b/diagnose-codespan-reporting/design.txt new file mode 100644 index 0000000..961017e --- /dev/null +++ b/diagnose-codespan-reporting/design.txt @@ -0,0 +1,38 @@ + ┌ outer gutter + │ ┌ left border + │ │ ┌ inner gutter + │ │ │ ┌─────────────────────────── source ─────────────────────────────┐ + │ │ │ │ │ + ┌──────────────────────────────────────────────────────────────────────────── + header ── │ error[0001]: oh noes, a cupcake has occurred! +snippet start ── │ ┌─ test:9:0 +snippet empty ── │ │ + snippet line ── │ 9 │ ╭ Cupcake ipsum dolor. Sit amet marshmallow topping cheesecake + snippet line ── │ 10 │ │ muffin. Halvah croissant candy canes bonbon candy. Apple pie jelly + │ │ ╭─│─────────^ +snippet break ── │ · │ │ + snippet line ── │ 33 │ │ │ Muffin danish chocolate soufflé pastry icing bonbon oat cake. + snippet line ── │ 34 │ │ │ Powder cake jujubes oat cake. Lemon drops tootsie roll marshmallow + │ │ │ ╰─────────────────────────────^ blah blah +snippet break ── │ · │ + snippet line ── │ 38 │ │ Brownie lemon drops chocolate jelly-o candy canes. Danish marzipan + snippet line ── │ 39 │ │ jujubes soufflé carrot cake marshmallow tiramisu caramels candy canes. + │ │ │ ^^^^^^^^^^^^^^^^^^^ -------------------- blah blah + │ │ │ │ + │ │ │ blah blah + │ │ │ note: this is a note + snippet line ── │ 40 │ │ Fruitcake jelly-o danish toffee. Tootsie roll pastry cheesecake + snippet line ── │ 41 │ │ soufflé marzipan. Chocolate bar oat cake jujubes lollipop pastry + snippet line ── │ 42 │ │ cupcake. Candy canes cupcake toffee gingerbread candy canes muffin + │ │ │ ^^^^^^^^^^^^^^^^^^ blah blah + │ │ ╰──────────^ blah blah +snippet break ── │ · + snippet line ── │ 82 │ gingerbread toffee chupa chups chupa chups jelly-o cotton candy. + │ │ ^^^^^^ ------- blah blah +snippet empty ── │ │ + snippet note ── │ = blah blah + snippet note ── │ = blah blah blah + │ blah blah + snippet note ── │ = blah blah blah + │ blah blah + empty ── │ diff --git a/diagnose-codespan-reporting/diagnose-codespan-reporting.cabal b/diagnose-codespan-reporting/diagnose-codespan-reporting.cabal index edb2ede..62fbfaa 100644 --- a/diagnose-codespan-reporting/diagnose-codespan-reporting.cabal +++ b/diagnose-codespan-reporting/diagnose-codespan-reporting.cabal @@ -28,6 +28,8 @@ library Error.Diagnose.Layout.CodeSpanReporting other-modules: Data.List.Safe + Error.Diagnose.Layout.CodeSpanReporting.Config + Error.Diagnose.Layout.CodeSpanReporting.Render Paths_diagnose_codespan_reporting hs-source-dirs: src diff --git a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs index 5718a92..cc05b1d 100644 --- a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs +++ b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs @@ -1,22 +1,22 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} -module Error.Diagnose.Layout.CodeSpanReporting (codespanReportingLayout) where +module Error.Diagnose.Layout.CodeSpanReporting (codespanReportingLayout, defaultStyle) where import qualified Data.Array.IArray as Array import Data.Array.Unboxed (IArray, Ix, UArray, listArray, (!)) import Data.Bifunctor (bimap, first, second) -import Data.Char.WCWidth (wcwidth) +import qualified Data.Char.WCWidth as W (wcwidth) +import Data.Char (ord) import Data.Default (def) import Data.Foldable (fold) import Data.Function (on) import Data.Functor ((<&>)) import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap -import Data.List (intersperse) import qualified Data.List as List import qualified Data.List.Safe as List import Data.Maybe (fromMaybe) @@ -26,9 +26,14 @@ import Error.Diagnose.Diagnostic (filesOf, reportsOf) import Error.Diagnose.Layout (FileMap, Layout) import Error.Diagnose.Position (Position (..)) import Error.Diagnose.Report (Marker (..), Note (..), Report (..)) -import Error.Diagnose.Style (Annotation (..)) -import Prettyprinter (Doc, Pretty, align, annotate, colon, hardline, lbracket, pretty, rbracket, space, width, (<+>)) +import Error.Diagnose.Style (Annotation (..), Style, reAnnotate) +import Prettyprinter (Doc, Pretty, align, annotate, brackets, colon, emptyDoc, hardline, pretty, space, width, (<+>)) import Prettyprinter.Internal.Type (Doc (..)) +import Text.Printf (printf) + +import Error.Diagnose (bold, color, Color(..), colorDull) +import qualified Error.Diagnose.Layout.CodeSpanReporting.Config as R +import qualified Error.Diagnose.Layout.CodeSpanReporting.Render as R -- | Pretty prints a 'Diagnostic' into a 'Doc'ument that can be output using 'hPutDoc'. -- @@ -41,11 +46,34 @@ import Prettyprinter.Internal.Type (Doc (..)) -- -- >>> let myCustomStyle :: Style = _ -- >>> let doc = myCustomStyle (prettyDiagnostic withUnicode tabSize diagnostic) -codespanReportingLayout :: Layout msg -codespanReportingLayout withUnicode tabSize diag = - fold . intersperse hardline $ prettyReport (filesOf diag) withUnicode tabSize <$> reportsOf diag +codespanReportingLayout :: Layout R.Annotation msg +codespanReportingLayout withUnicode tabSize diag + = foldMap (R.report (filesOf diag) chars tabSize) (reportsOf diag) + -- fold . intersperse hardline $ prettyReport (filesOf diag) withUnicode tabSize <$> reportsOf diag + where chars = if withUnicode then R.unicodeChars else R.asciiChars {-# INLINE codespanReportingLayout #-} +defaultStyle :: Style R.Annotation +defaultStyle = reAnnotate \case + R.Header R.Bug -> bold <> color Red + R.Header R.Error -> bold <> color Red + R.Header R.Warning -> bold <> color Yellow + R.Header R.Note -> bold <> color Green + R.Header R.Help -> bold <> color Cyan + R.HeaderMessage -> bold <> color White + R.SourceBorder -> colorDull Cyan -- Blue + R.NoteBullet -> colorDull Cyan -- Blue + R.LineNumber -> colorDull Cyan -- Blue + R.SourceTint sev sty -> marker sev sty + R.MarkerTint sev sty -> marker sev sty + where marker R.Bug R.SThis = colorDull Red + marker R.Error R.SThis = colorDull Red + marker R.Warning R.SThis = colorDull Yellow + marker R.Note R.SThis = colorDull Green + marker R.Help R.SThis = colorDull Cyan + marker _ R.SBlank = mempty + marker _ _ = colorDull Cyan -- Blue + -------------------------------------- ------------- INTERNAL --------------- -------------------------------------- @@ -93,43 +121,22 @@ prettyReport' fileContent withUnicode tabSize isError code message markers hints header = annotate (KindColor isError) - ( lbracket - <> ( if isError - then "error" - else "warning" - ) - <> case code of - Nothing -> rbracket - Just code -> space <> pretty code <> rbracket - ) + ((if isError then "error" else "warning") + <> maybe emptyDoc (brackets . pretty) code) in {- A report is of the form: - (1) [error|warning]: - (2) +--> - (3) : + (1) []: + (2) --> + (3) | (4) | - : - : - (5) : - : - (6) -------+ + (5) | + (6) | + (7) = -} {- (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 <+> dotPrefix maxLineNumberLength withUnicode - ) - <> prettyAllHints 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 "+") - <> hardline - ) + <> {- (2)..(6) -} fold (uncurry (prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength) <$> groupedMarkers) + <> {- (7) -} prettyAllHints hints maxLineNumberLength withUnicode ------------------------------------------------------------------------------------- ----- INTERNAL STUFF ---------------------------------------------------------------- @@ -139,6 +146,18 @@ prettyReport' fileContent withUnicode tabSize isError code message markers hints pad :: Int -> Char -> Doc ann -> Doc ann pad n c d = width d \w -> pretty $ replicate (n - w) c +-- | Creates a "="-prefix for hints at the end of the report. +-- +-- Pretty printing yields those results: +-- +-- "@␣␣␣␣␣=␣@" +hintBullet :: + -- | The length of the left space before the bullet. + Int -> + Doc Annotation +hintBullet leftLen = pad leftLen ' ' emptyDoc <+> annotate RuleColor "=" +{-# INLINE hintBullet #-} + -- | Creates a "dot"-prefix for a report line where there is no code. -- -- Pretty printing yields those results: @@ -151,7 +170,7 @@ dotPrefix :: -- | Whether to print with unicode characters or not. Bool -> Doc Annotation -dotPrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (if withUnicode then "•" else ":") +dotPrefix leftLen withUnicode = pad leftLen ' ' emptyDoc <+> annotate RuleColor (if withUnicode then "•" else ":") {-# INLINE dotPrefix #-} -- | Creates a "pipe"-prefix for a report line where there is no code. @@ -166,7 +185,7 @@ pipePrefix :: -- | Whether to print with unicode characters or not. Bool -> Doc Annotation -pipePrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (if withUnicode then "│" else "|") +pipePrefix leftLen withUnicode = pad leftLen ' ' emptyDoc <+> annotate RuleColor (if withUnicode then "│" else "|") {-# INLINE pipePrefix #-} -- | Creates a line-prefix for a report line containing source code @@ -187,7 +206,7 @@ linePrefix :: Doc Annotation 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 $ emptyDoc <+> pad (leftLen - lineNoLen) ' ' emptyDoc <> pretty lineNo <+> if withUnicode then "│" else "|" {-# INLINE linePrefix #-} -- | Creates an ellipsis-prefix, when some line numbers are not consecutive. @@ -200,7 +219,7 @@ ellipsisPrefix :: Int -> Bool -> Doc Annotation -ellipsisPrefix leftLen withUnicode = pad leftLen ' ' mempty <> annotate RuleColor (if withUnicode then space <> "⋮" else "...") +ellipsisPrefix leftLen withUnicode = pad leftLen ' ' emptyDoc <> annotate RuleColor (if withUnicode then space <> "⋮" else "...") groupMarkersPerFile :: Pretty msg => @@ -208,9 +227,9 @@ groupMarkersPerFile :: [(Bool, [(Position, Marker msg)])] groupMarkersPerFile [] = [] groupMarkersPerFile markers = - let markersPerFile = List.foldl' (HashMap.unionWith (<>)) mempty $ markers <&> \tup@(p, _) -> HashMap.singleton (file p) [tup] + let markersPerFile = List.foldl' (HashMap.unionWith (<>)) HashMap.empty $ markers <&> \tup@(p, _) -> HashMap.singleton (file p) [tup] in -- put all markers on the same file together - -- NOTE: it's a shame that `HashMap.unionsWith f = foldl' (HashMap.unionWith f) mempty` does not exist + -- NOTE: it's a shame that `HashMap.unionsWith f = foldl' (HashMap.unionWith f) emptyDoc` does not exist onlyFirstToTrue $ putThisMarkersAtTop $ HashMap.elems markersPerFile where @@ -225,6 +244,9 @@ groupMarkersPerFile markers = | any isThisMarker (snd <$> ms2) -> GT | otherwise -> EQ +prettyPosition :: Position -> Doc Annotation +prettyPosition (Position (l, c) _ file) = pretty file <> colon <> pretty l <> colon <> pretty c + -- | Prettyprint a sub-report, which is a part of the report spanning across a single file prettySubReport :: Pretty msg => @@ -249,25 +271,17 @@ prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength isFi sortedMarkersPerLine = {- second (List.sortOn (first $ snd . begin)) <$> -} List.sortOn fst (HashMap.toList markersPerLine) - reportFile = maybe (pretty @Position def) (pretty . fst) $ List.safeHead (List.sortOn (Down . snd) markers) + reportFile = prettyPosition $ maybe def fst $ List.safeHead (List.sortOn (Down . snd) markers) -- the reported file is the file of the first 'This' marker (only one must be present) allLineNumbers = List.sort $ List.nub $ (fst <$> sortedMarkersPerLine) <> (multilineMarkers >>= \(Position (bl, _) (el, _) _, _) -> [bl .. el]) fileMarker = - ( if isFirst - then - space <> pad maxLineNumberLength ' ' mempty - <+> annotate RuleColor (if withUnicode then "╭──▶" else "+-->") - else - space <> dotPrefix maxLineNumberLength withUnicode <> hardline - <> annotate RuleColor (pad (maxLineNumberLength + 2) (if withUnicode then '─' else '-') mempty) - <> annotate RuleColor (if withUnicode then "┼──▶" else "+-->") - ) + space <> pad maxLineNumberLength ' ' emptyDoc + <+> annotate RuleColor (if withUnicode then "┌─" else "-->") <+> annotate FileColor reportFile - in {- (2) -} hardline <> fileMarker - <> hardline - <+> {- (3) -} pipePrefix maxLineNumberLength withUnicode + in {- (2) -} hardline <> fileMarker <> hardline + <+> {- (3) -} pipePrefix maxLineNumberLength withUnicode <> {- (4) -} prettyAllLines fileContent withUnicode isError tabSize maxLineNumberLength sortedMarkersPerLine multilineMarkers allLineNumbers isThisMarker :: Marker msg -> Bool @@ -276,7 +290,7 @@ isThisMarker _ = False -- | splitMarkersPerLine :: [(Position, Marker msg)] -> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)]) -splitMarkersPerLine [] = (mempty, mempty) +splitMarkersPerLine [] = (HashMap.empty, []) splitMarkersPerLine (m@(Position {..}, _) : ms) = let (bl, _) = begin (el, _) = end @@ -307,17 +321,25 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu l1 : l2 : ls -> let (ms, doc) = showForLine False l1 in doc - <> (if l2 /= l1 + 1 then hardline <+> dotPrefix leftLen withUnicode else mempty) + <> (if l2 /= l1 + 1 then hardline <+> dotPrefix leftLen withUnicode else emptyDoc) <> prettyAllLines files withUnicode isError tabSize leftLen inline ms (l2 : ls) where showForLine isLastLine line = {- A line of code is composed of: (1) | - (2) : - (3) : - - Multline markers may also take additional space (2 characters) on the right of the bar + (2) | + + Multline markers may further indent the code: + (1) │ ╭ + (2) │ │ + │ │ ╭ + │ │ │ + (3) · │ │ + │ │ │ + (4) │ │ ╰' + │ │ else + (5) │ ╰───^ -} let allInlineMarkersInLine = snd =<< filter ((==) line . fst) inline @@ -339,7 +361,7 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu if not $ null allMultilineMarkersSpanningLine then colorOfFirstMultilineMarker if withUnicode then "│ " else "| " else " " - else mempty + else emptyDoc (p@(Position _ (el, _) _), marker) : _ -> let hasPredecessor = el == line || maybe False ((/=) p . fst . fst) (List.safeUncons multiline) in colorOfFirstMultilineMarker @@ -365,7 +387,7 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu <> showMultiline (isLastLine || List.safeLast multilineEndingOnLine == List.safeLast multiline) multilineEndingOnLine ) - showMultiline _ [] = mempty + showMultiline _ [] = emptyDoc showMultiline isLastMultiline 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 @@ -374,7 +396,7 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu prefixWithBar color = prefix <> maybe id annotate color (if withUnicode then "│ " else "| ") - showMultilineMarkerMessage (_, Blank) _ = mempty + showMultilineMarkerMessage (_, Blank) _ = emptyDoc showMultilineMarkerMessage (_, marker) isLast = annotate (markerColor isError marker) $ ( if isLast && isLastMultiline @@ -428,24 +450,29 @@ getLine_ files markers line tabSize isError = mkWidthTable :: String -> WidthTable mkWidthTable s = listArray (1, length s) (ifTab tabSize wcwidth <$> s) + wcwidth :: Char -> Int + wcwidth c@(W.wcwidth -> w) + | w >= 0 = w + | otherwise = error (printf "negative width for '%c' (0x%04x)" c (ord c)) + -- | showAllMarkersInLine :: Pretty msg => Bool -> Bool -> (Doc Annotation -> Doc Annotation) -> Bool -> Bool -> Int -> WidthTable -> [(Position, Marker msg)] -> Doc Annotation -showAllMarkersInLine _ _ _ _ _ _ _ [] = mempty +showAllMarkersInLine _ _ _ _ _ _ _ [] = emptyDoc 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 + | otherwise = emptyDoc 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 <+> dotPrefix leftLen withUnicode <+> (if List.null ms then emptyDoc else specialPrefix <> showMarkers 1 maxMarkerColumn <> showMessages specialPrefix ms maxMarkerColumn) where widthAt i = 0 `fromMaybe` safeArrayIndex i widths widthsBetween start end = sum $ take (end - start) $ drop (start - 1) $ Array.elems widths showMarkers n lineLen - | n > lineLen = mempty -- reached the end of the line + | n > lineLen = emptyDoc -- reached the end of the line | otherwise = let allMarkers = flip filter ms \(Position (_, bc) (_, ec) _, mark) -> mark /= Blank && n >= bc && n < ec in -- only consider markers which span onto the current column @@ -461,7 +488,7 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn <> showMarkers (n + 1) lineLen showMessages specialPrefix ms lineLen = case List.safeUncons ms of - Nothing -> mempty -- no more messages to show + Nothing -> emptyDoc -- no more messages to show Just ((Position b@(_, bc) _ _, msg), pipes) -> let filteredPipes = filter (uncurry (&&) . bimap ((/= b) . begin) (/= Blank)) pipes -- record only the pipes corresponding to markers on different starting positions @@ -525,9 +552,10 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn -- | replaceLinesWith :: Doc ann -> Doc ann -> Doc ann replaceLinesWith repl Line = repl -replaceLinesWith _ Fail = Fail -replaceLinesWith _ Empty = Empty -replaceLinesWith _ (Char c) = Char c +replaceLinesWith _ Fail = Fail +replaceLinesWith _ Empty = Empty +replaceLinesWith repl (Char '\n') = repl +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) @@ -565,18 +593,18 @@ markerMessage Blank = undefined -- | Pretty prints all hints. prettyAllHints :: Pretty msg => [Note msg] -> Int -> Bool -> Doc Annotation -prettyAllHints [] _ _ = mempty +prettyAllHints [] _ _ = emptyDoc prettyAllHints (h : hs) leftLen withUnicode = {- A hint is composed of: - (1) : Hint: + (1) = hint: -} - let prefix = hardline <+> pipePrefix leftLen withUnicode - in prefix <+> annotate HintColor (notePrefix h <+> replaceLinesWith (prefix <+> " ") (pretty $ noteMessage h)) + let prefix = hardline <+> hintBullet leftLen + in prefix <+> annotate HintColor (notePrefix h <+> pretty (noteMessage h)) <> prettyAllHints hs leftLen withUnicode where - notePrefix (Note _) = "Note:" - notePrefix (Hint _) = "Hint:" + notePrefix (Note _) = "note:" + notePrefix (Hint _) = "hint:" noteMessage (Note msg) = msg noteMessage (Hint msg) = msg diff --git a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Config.hs b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Config.hs new file mode 100644 index 0000000..1303bc6 --- /dev/null +++ b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Config.hs @@ -0,0 +1,92 @@ +module Error.Diagnose.Layout.CodeSpanReporting.Config where + +data Chars = Chars + -- | The characters to use for the top-left border of the snippet. + -- Defaults to: @┌─@ or @-->@ with asciiChars. + { cSnippetStart :: String + -- | The character to use for the left border of the source. + -- Defaults to: @│@ or @|@ with asciiChars. + , cSourceBorderLeft :: Char + -- | The character to use for the left border break of the source. + -- Defaults to: @·@ or @.@ with asciiChars. + , cSourceBorderLeftBreak :: Char + -- | The character to use for the note bullet. + -- Defaults to: @=@. + , cNoteBullet :: Char + -- | The character to use for marking a single-line primary label. + -- Defaults to: @^@. + , cSinglePrimaryCaret :: Char + -- | The character to use for marking a single-line secondary label. + -- Defaults to: @-@. + , cSingleSecondaryCaret :: Char + -- | The character to use for marking the start of a multi-line primary label. + -- Defaults to: @^@. + , cMultiPrimaryCaretStart :: Char + -- | The character to use for marking the end of a multi-line primary label. + -- Defaults to: @^@. + , cMultiPrimaryCaretEnd :: Char + -- | The character to use for marking the start of a multi-line secondary label. + -- Defaults to: @\'@. + , cMultiSecondaryCaretStart :: Char + -- | The character to use for marking the end of a multi-line secondary label. + -- Defaults to: @\'@. + , cMultiSecondaryCaretEnd :: Char + -- | The character to use for the top-left corner of a multi-line label. + -- Defaults to: @╭@ or @/@ with asciiChars. + , cMultiTopLeft :: Char + -- | The character to use for the top of a multi-line label. + -- Defaults to: @─@ or @-@ with asciiChars. + , cMultiTop :: Char + -- | The character to use for the bottom-left corner of a multi-line label. + -- Defaults to: @╰@ or @\\@ with asciiChars. + , cMultiBottomLeft :: Char + -- | The character to use when marking the bottom of a multi-line label. + -- Defaults to: @─@ or @-@ with asciiChars. + , cMultiBottom :: Char + -- | The character to use for the left of a multi-line label. + -- Defaults to: @│@ or @|@ with asciiChars. + , cMultiLeft :: Char + -- | The character to use for the left of a pointer underneath a caret. + -- Defaults to: @│@ or @|@ with asciiChars. + , cPointerLeft :: Char + } deriving (Show) + +unicodeChars :: Chars +unicodeChars = Chars + { cSnippetStart = "┌─" + , cSourceBorderLeft = '│' + , cSourceBorderLeftBreak = '·' + , cNoteBullet = '=' + , cSinglePrimaryCaret = '^' + , cSingleSecondaryCaret = '-' + , cMultiPrimaryCaretStart = '^' + , cMultiPrimaryCaretEnd = '^' + , cMultiSecondaryCaretStart = '\'' + , cMultiSecondaryCaretEnd = '\'' + , cMultiTopLeft = '╭' + , cMultiTop = '─' + , cMultiBottomLeft = '╰' + , cMultiBottom = '─' + , cMultiLeft = '│' + , cPointerLeft = '│' + } + +asciiChars :: Chars +asciiChars = Chars + { cSnippetStart = "-->" + , cSourceBorderLeft = '|' + , cSourceBorderLeftBreak = '.' + , cNoteBullet = '=' + , cSinglePrimaryCaret = '^' + , cSingleSecondaryCaret = '-' + , cMultiPrimaryCaretStart = '^' + , cMultiPrimaryCaretEnd = '^' + , cMultiSecondaryCaretStart = '\'' + , cMultiSecondaryCaretEnd = '\'' + , cMultiTopLeft = '/' + , cMultiTop = '-' + , cMultiBottomLeft = '\\' + , cMultiBottom = '-' + , cMultiLeft = '|' + , cPointerLeft = '|' + } diff --git a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs new file mode 100644 index 0000000..76fb348 --- /dev/null +++ b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs @@ -0,0 +1,374 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DerivingVia #-} +module Error.Diagnose.Layout.CodeSpanReporting.Render where + +import Error.Diagnose.Layout.CodeSpanReporting.Config + +import qualified Data.Array.IArray as A (array, bounds, (!)) +import qualified Data.HashMap.Lazy as H ((!?)) +import qualified Data.Text as T (length, split) +import Data.Array.Unboxed (UArray) +import Data.Char (isSpace, ord) +import Data.Char.WCWidth (wcwidth) +import Data.Foldable (maximumBy) +import Data.Function (on) +import Data.List (groupBy, nub, sort, sortOn, dropWhileEnd, intersperse) +import Data.Maybe (isJust, fromJust) +import Data.Ord (comparing) +import Control.Arrow ((&&&)) +import Text.Printf (printf) + +import Error.Diagnose (Position(..), Marker(..), Report(..), Note, align, hsep) +import qualified Error.Diagnose as E (Note(Note, Hint)) +import Error.Diagnose.Layout (FileMap) +import Prettyprinter (Doc, Pretty(..), (<+>), annotate, brackets, emptyDoc, colon, space, hardline, column, fill) +import Prettyprinter.Internal (Doc(..)) +import Debug.Trace (traceShowId) + +unicodeWidth :: Int -> Int -> Char -> Int +unicodeWidth tabSize col c@(wcwidth -> w) + | w >= 0 = w + | c == '\t' = (col `div` tabSize + 1) * tabSize - col + | otherwise = error (printf "negative width for '%c' (0x%04x)" c (ord c)) + +data Severity + = Bug + | Error + | Warning + | Help + | Note + deriving (Show, Eq, Ord) + +instance Pretty Severity where + pretty Bug = "bug" + pretty Error = "error" + pretty Warning = "warning" + pretty Help = "help" + pretty Note = "note" + +data Annotation + = Header Severity + | HeaderMessage + | SourceBorder + | NoteBullet + | LineNumber + | SourceTint Severity MarkerStyle + | MarkerTint Severity MarkerStyle + deriving (Show, Eq) + +data MarkerStyle + = SThis + | SWhere + | SMaybe + | SBlank + deriving (Show, Eq, Ord) + +nonBlank :: [(a, Marker msg)] -> [(a, Marker msg)] +nonBlank = filter ((/= SBlank) . markerStyle . snd) + +markerStyle :: Marker msg -> MarkerStyle +markerStyle (This _) = SThis +markerStyle (Where _) = SWhere +markerStyle (Maybe _) = SMaybe +markerStyle Blank = SBlank + +markerMessage :: Marker msg -> Maybe msg +markerMessage (This msg) = Just msg +markerMessage (Where msg) = Just msg +markerMessage (Maybe msg) = Just msg +markerMessage Blank = Nothing + +reportComponents :: Report msg -> (Severity, Maybe msg, msg, [(Position, Marker msg)], [Note msg]) +reportComponents (Warn code msg markers notes) = (Warning, code, msg, markers, notes) +reportComponents (Err code msg markers notes) = (Error, code, msg, markers, notes) + +takeNAndOthers :: Pretty a => Int -> [a] -> Doc ann +takeNAndOthers 0 _ = error "takeNAndOthers: cannot take 0" +takeNAndOthers _ [] = error "takeNAndOthers: empty list" +takeNAndOthers n (first : rest) = pretty first <> go (pred n) rest + where go _ [] = emptyDoc + go 0 [x] = ", and " <> pretty x + go 0 others = ", and " <> pretty (length others) <> " other(s)" + go k (x : xs) = ", " <> pretty x <> go (pred k) xs + +report :: Pretty msg => FileMap -> Chars -> Int -> Report msg -> Doc Annotation +report fileMap chars@Chars{ cNoteBullet, cSourceBorderLeft } + tabSize (reportComponents -> (sev, code, msg, markers, notes)) + = header sev code msg <> foldMap renderFile groups + <> foldMap renderNote notes + where groups = sortMarkers markers + maxLnWidth = length $ show $ maximum $ 0 : concatMap go markers + where go (Position{ begin, end }, _) = [fst begin, snd end] + leftPadding = pad maxLnWidth "" + trailingLeftBorder = leftPadding <+> annotate SourceBorder (pretty cSourceBorderLeft) <> hardline + sortMarkers + = map (file . fst . head &&& id) + . groupBy ((==) `on` file . fst) + . sortOn (posToTriple . fst) + posToTriple Position{ begin, end, file } = (file, begin, end) + renderFile (fileName, thisMarkers@(classifyMarkers -> (groupSingles -> singleWithLines, multis))) + | Just fileLines <- fileMap H.!? fileName + , missingLines <- filter (not . (`inRange` A.bounds fileLines) . pred) lineNumbers + = if null missingLines then + let go (b, ln, singles) = sourceLine chars tabSize b ln maxLnWidth (fileLines A.! pred ln) sev singles multis + in snippetStart chars maxLnWidth startPos <> foldMap go allLines <> trailingLeftBorder + else makeBug ("line " <> takeNAndOthers 2 missingLines <> " of file '" <> pretty fileName <> "' not available") + | otherwise = makeBug ("content of file '" <> pretty fileName <> "' not available") + where lineNumbers = map fst singleWithLines ++ concatMap linesForMulti multis + allLines = fillGap $ merge singleWithLines $ nub $ sort $ concatMap linesForMulti multis + merge [] ys = map (, []) ys + merge xs [] = xs + merge (x : xs) (y : ys) = case compare (fst x) y of + LT -> x : merge xs (y : ys) + EQ -> x : merge xs ys + GT -> (y, []) : merge (x : xs) ys + fillGap ((lnX, x) : xs@((lnY, _) : _)) + | lnX + 1 == lnY = (True, lnX, x) : fillGap xs + | lnX + 2 == lnY = (True, lnX, x) : (True, succ lnX, []) : fillGap xs + | otherwise = (True, lnX, x) : (False, succ lnX, []) : fillGap xs + fillGap xs = map (\(ln, t) -> (True, ln, t)) xs + linesForMulti (((lnS, _), (lnE, _)), _) = [lnS, lnE] + startPos = fst (head thisMarkers) + makeBug s = leftPadding <+> annotate (Header Bug) "bug" <> annotate HeaderMessage (colon <+> s) <> hardline + groupSingles = map (fst . head &&& map snd) . groupBy ((==) `on` fst) + renderNote nt + -- ' = : ' + = leftPadding <+> annotate NoteBullet (pretty cNoteBullet) + <+> pretty @String noteLevel <> colon <+> align (pretty noteMsg) <> hardline + where (noteLevel, noteMsg) = case nt of + E.Hint m -> ("hint", m) + E.Note m -> ("note", m) + +partitionEither :: (a -> Either b c) -> [a] -> ([b], [c]) +partitionEither p = foldr go ([], []) + where go (p -> Left b) ~(bs, cs) = (b : bs, cs) + go (p -> Right c) ~(bs, cs) = (bs, c : cs) + +classifyMarkers :: [(Position, Marker msg)] -> ([(Line, SingleMarker msg)], [MultiMarker msg]) +classifyMarkers = partitionEither \(pos, marker) -> + let Position{ begin = begin@(lnS, colS), end = end@(lnE, colE) } = pos + in if lnS == lnE then Left (lnS, ((colS, colE), marker)) else Right ((begin, end), marker) + +header :: Pretty msg => Severity -> Maybe msg -> msg -> Doc Annotation +header sev code msg + -- header: 'error[E0001]' + = annotate (Header sev) (pretty sev <> maybe emptyDoc (brackets . pretty) code) + -- message: ': unexpected type in `+` application' + <> annotate HeaderMessage (colon <+> align (pretty msg)) <> hardline + +snippetStart :: Chars -> Int -> Position -> Doc Annotation +snippetStart Chars{ cSnippetStart } k Position{ file, begin = (ln, col) } + -- rendered as: ' ┌─ test:2:9' + = pad k "" <+> annotate SourceBorder (pretty cSnippetStart) + <+> pretty file <> colon <> pretty ln <> colon <> pretty col + <> hardline + +padWith :: Int -> String -> (Doc ann -> Doc ann) -> Doc ann +padWith w t f = pretty (replicate (w - length t) ' ') <> f (pretty t) + +pad :: Int -> String -> Doc ann +pad w t = padWith w t id + +type Line = Int +type Column = Int +type Range a = (a, a) + +inRange :: Ord a => a -> Range a -> Bool +x `inRange` (l, r) = l <= x && x <= r + +isOverlapping :: Ord a => Range a -> Range a -> Bool +isOverlapping (l1, r1) (l2, r2) = r1 >= l2 && r2 >= l1 + +type SingleMarker msg = (Range Column, Marker msg) +type MultiMarker msg = (Range (Line, Column), Marker msg) + +-- note: we allow a one-pass-the-end index (to allow place a caret here) +mkWidthTable :: Int -> String -> UArray Int Int +mkWidthTable tabSize s = A.array (1, length s + 1) $ zip [1..] $ scanl go 0 s + where go n c = n + unicodeWidth tabSize n c + +indexed :: [a] -> [(Int, a)] +indexed = zip [0..] + +filterIndex :: (Int -> Bool) -> [a] -> [a] +filterIndex p = map snd . filter (p . fst) . indexed + +filterIndexed :: (a -> Bool) -> [a] -> [(Int, a)] +filterIndexed p = filter (p . snd) . indexed + +-- | Rendered source line, with line number and multi-line markers on the left. +-- +-- > 10 │ │ muffin. Halvah croissant candy canes bonbon candy. Apple pie jelly +-- > │ ╭─│─────────^ +sourceLine + :: Pretty msg + => Chars + -> Int -- ^ tab size. + -> Bool -- ^ 'True' - real source line; 'False' - gap. + -> Int -- ^ line number. + -> Int -- ^ width for the line number. + -> String -- ^ source code. + -> Severity -- ^ severity of the message for this line. + -> [SingleMarker msg] -- single-line markers. + -> [MultiMarker msg] -- multi-line markers. + -> Doc Annotation +sourceLine Chars{..} tabSize isRealSource ln lnWidth + (trimEnd -> text) sev (nonBlank -> singles) (nonBlank -> multis) + -- > 10 │ │ muffin. Halvah croissant candy canes bonbon candy. Apple pie jelly + = headLeader <+> attachColour text <> hardline + -- > │ │ ^^^^^^ -------^^^^^^^^^-------^^^^^------- ^^^^^ trailing label message + <> (if null singles then emptyDoc else + tailLeader <+> drawMarkers text <> trailingMsgRendered <> hardline) + <> (if nDanglingMsgs == 0 then emptyDoc else + -- > │ │ │ │ + allPointerLines <> hardline + -- > │ │ │ croissant is mentioned here + -- > │ │ muffin is first mentioned here + -- > │ │ help: the answer is 42 + <> drawDanglingMsgs (pred nDanglingMsgs)) + -- > │ ╭─│─────────^ + <> foldMap renderMultiTopBottom (indexed multis) + where + headLeader = lineNumber <+> leaders True + tailLeader = pad lnWidth "" <+> leaders False + lineNumber = if isRealSource then padWith lnWidth (show ln) (annotate LineNumber) else pad lnWidth "" + -- handle leading multi-line markers + leaders isSource = border <+> hsep (map (leadingMarker isSource) multis) + border = annotate SourceBorder (pretty if isRealSource then cSourceBorderLeft else cSourceBorderLeftBreak) + leadingMarker isSource (((lnS, colS), (lnE, _)), markerStyle -> st) + | lnS == ln, colS <= leadingSpaces, isSource = ann (pretty cMultiTopLeft) + | lnS < ln, ln <= lnE = ann (pretty cMultiLeft) + | otherwise = space + where ann = annotate (MarkerTint sev st) + leadingSpaces = length (takeWhile isSpace text) + -- attach colour for the source code text + attachColour + = foldMap (renderSegment . (fst . head &&& concatMap snd)) + . groupBy ((==) `on` fst) + . zip (map styleOf [1..]) + . zipWith handleTab [0..] + handleTab k '\t' = replicate (unicodeWidth tabSize k '\t') ' ' + handleTab _ c = [c] + renderSegment (st, s) = annotate (SourceTint sev st) (pretty s) + maxStyle = minimum . (SBlank :) . map (markerStyle . snd) + styleOf col = + let s = filter (inRange col . fst) singles + m = filter (inRange (ln, col) . fst) multis + in maxStyle s `min` maxStyle m + -- handle single-line markers + drawMarkers + = foldMap renderMarker + . dropWhileEnd ((== SBlank) . fst) + . map (fst . head &&& sum . map snd) + . groupBy ((==) `on` fst) + . zip (map styleOfSingle [1..]) + . (++ [1]) + . zipWith (unicodeWidth tabSize) [0..] + renderMarker (st, k) = ann (pretty (replicate k c)) + where c | SThis <- st = cSinglePrimaryCaret + | SBlank <- st = ' ' + | otherwise = cSingleSecondaryCaret + ann = if st == SBlank then id else annotate (MarkerTint sev st) + styleOfSingle col = maxStyle (filter (inRange col . fst) singles) + trailingMsgRendered = maybe emptyDoc go trailingMsg + where go (_, markerStyle &&& markerMessage -> (st, ~(Just msg))) + = space <> align' st (pretty msg) + align' st payload = column \cur -> replaceLinesWith + (hardline <> fill cur allPointerLines) + (annotate (MarkerTint sev st)) + payload + trailingMsgCandidate = if null candidates then Nothing else Just res + where col (_, ((_, colE), _)) = colE + msg (_, (_, m)) = markerMessage m + candidates = filter (isJust . msg) (zip @Int [0..] singles) + res = maximumBy (comparing col) candidates + trailingMsg + -- found one last message + | Just (idx, (rng, msg)) <- trailingMsgCandidate + -- the source range does not overlap with any other + , all (\(rng', _) -> not (isOverlapping rng rng')) + $ filterIndex (/= idx) singles + -- keep the index to avoid rendering it in dangling style again + = Just (idx, msg) + | otherwise = Nothing + -- handle dangling messages for single-line markers + widthTable = mkWidthTable tabSize text + danglingMsgs + = filter ((/= SBlank) . markerStyle . snd) + $ filterIndex ((/= fmap fst trailingMsg) . Just) singles + nDanglingMsgs = length danglingMsgs + renderDanglingUntil k = foldl go emptyDoc (take k danglingMsgs) + where go cur ((colS, _), markerStyle -> st) + = fill (widthTable A.! colS) cur <> annotate (MarkerTint sev st) (pretty cPointerLeft) + allPointerLines = tailLeader <+> renderDanglingUntil nDanglingMsgs + drawDanglingMsgs k + | k < 0 = emptyDoc + | otherwise = leader <> pMsg <> hardline <> drawDanglingMsgs (pred k) + where ((colS, _), marker) = danglingMsgs !! k + ~(Just msg) = markerMessage marker + st = markerStyle marker + pMsg = replaceLinesWith (hardline <> leader) (annotate (MarkerTint sev st)) (pretty msg) + leader = tailLeader <+> fill (widthTable A.! colS) (renderDanglingUntil k) + -- handle multi-line markers (top & bottom rules) + renderMultiTopBottom (k, (((lnS, colS), (lnE, colE)), outer)) + | lnE == ln = multiLeader True <> ann outerSt (replicate (pred colE) cMultiBottom ++ [ed]) <+> pMsg <> hardline + | isStart = multiLeader True <> ann outerSt (replicate (pred colS) cMultiTop ++ [st]) <> hardline + | otherwise = emptyDoc + where leader = pad lnWidth "" <+> border + multiLeader isMain = leader <+> foldMap (multiMarkerLeft isMain) (indexed multis) + isStart = lnS == ln && colS > leadingSpaces + cBar = if isStart then cMultiTop else cMultiBottom + pMsg = replaceLinesWith cont annDoc $ pretty $ fromJust $ markerMessage outer + cont = hardline <> multiLeader False <> pretty (replicate (succ colE) ' ') + outerSt = markerStyle outer + annDoc = annotate (MarkerTint sev outerSt) + ann m = annotate (MarkerTint sev m) . pretty + st = if markerStyle outer == SThis then cMultiPrimaryCaretStart else cMultiSecondaryCaretStart + ed = if markerStyle outer == SThis then cMultiPrimaryCaretEnd else cMultiSecondaryCaretEnd + multiMarkerLeft isMain (k', (((lnS', _), (lnE', _)), markerStyle -> inner)) + | through, k' < k = ann inner cMultiLeft <> space + | through = ann inner cMultiLeft <> pBar + | lnS' == ln, k' < k = ann inner cMultiLeft <> space + | lnE' == ln, k' > k = ann inner cMultiLeft <> pBar + | lnS == ln, k' == k, isMain = ann outerSt [cMultiTopLeft, cMultiTop] + | lnE == ln, k' == k, isMain = ann outerSt [cMultiBottomLeft, cMultiBottom] + | k' > k, isMain = ann outerSt [cBar, cBar] + | otherwise = " " + where through = lnS' < ln && ln < lnE' + pBar = if isMain then ann outerSt cBar else space + +trim, trimStart, trimEnd :: String -> String +trim = trimStart . trimEnd +trimStart = dropWhile isSpace +trimEnd = dropWhileEnd isSpace +-- WARN: uses the internal of the library 'prettyprinter' +-- +-- DO NOT use a wildcard here, in case the internal API exposes one more constructor + +-- | +replaceLinesWith :: Doc ann -> (Doc ann -> Doc ann) -> Doc ann -> Doc ann +replaceLinesWith repl t = go + where + go Line = repl + go Fail = Fail + go Empty = Empty + go (Char '\n') = repl + go (Char c) = Char c + go (Text _ s) + = mconcat + $ intersperse repl + $ map t + $ uncurry Text . (T.length &&& id) + <$> T.split (== '\n') s + go (FlatAlt f d) = FlatAlt (go f) (go d) + go (Cat c d) = Cat (go c) (go d) + go (Nest n d) = Nest n (go d) + go (Union c d) = Union (go c) (go d) + go (Column f) = Column (go . f) + go (Nesting f) = Nesting (go . f) + go (Annotated ann doc) = Annotated ann (go doc) + go (WithPageWidth f) = WithPageWidth (go . f) From 101264c09da2665b66f221a8ec00c9ca587530e7 Mon Sep 17 00:00:00 2001 From: Ruifeng Xie Date: Tue, 13 Sep 2022 20:01:26 +0800 Subject: [PATCH 03/10] cleanup Error.Diagnose.CodeSpanReporting --- .../Diagnose/Layout/CodeSpanReporting.hs | 571 +----------------- 1 file changed, 2 insertions(+), 569 deletions(-) diff --git a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs index cc05b1d..2d64e81 100644 --- a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs +++ b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs @@ -1,35 +1,8 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} - module Error.Diagnose.Layout.CodeSpanReporting (codespanReportingLayout, defaultStyle) where -import qualified Data.Array.IArray as Array -import Data.Array.Unboxed (IArray, Ix, UArray, listArray, (!)) -import Data.Bifunctor (bimap, first, second) -import qualified Data.Char.WCWidth as W (wcwidth) -import Data.Char (ord) -import Data.Default (def) -import Data.Foldable (fold) -import Data.Function (on) -import Data.Functor ((<&>)) -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Lazy as HashMap -import qualified Data.List as List -import qualified Data.List.Safe as List -import Data.Maybe (fromMaybe) -import Data.Ord (Down (..)) -import qualified Data.Text as Text import Error.Diagnose.Diagnostic (filesOf, reportsOf) -import Error.Diagnose.Layout (FileMap, Layout) -import Error.Diagnose.Position (Position (..)) -import Error.Diagnose.Report (Marker (..), Note (..), Report (..)) -import Error.Diagnose.Style (Annotation (..), Style, reAnnotate) -import Prettyprinter (Doc, Pretty, align, annotate, brackets, colon, emptyDoc, hardline, pretty, space, width, (<+>)) -import Prettyprinter.Internal.Type (Doc (..)) -import Text.Printf (printf) +import Error.Diagnose.Layout (Layout) +import Error.Diagnose.Style (Style, reAnnotate) import Error.Diagnose (bold, color, Color(..), colorDull) import qualified Error.Diagnose.Layout.CodeSpanReporting.Config as R @@ -73,543 +46,3 @@ defaultStyle = reAnnotate \case marker R.Help R.SThis = colorDull Cyan marker _ R.SBlank = mempty marker _ _ = colorDull Cyan -- Blue - --------------------------------------- -------------- INTERNAL --------------- --------------------------------------- - -type WidthTable = UArray Int Int - --- | Pretty prints a report to a 'Doc' handling colors. -prettyReport :: - Pretty msg => - -- | The content of the file the reports are for - FileMap -> - -- | Should we print paths in unicode? - Bool -> - -- | The number of spaces each TAB character will span - Int -> - -- | The whole report to output - Report msg -> - Doc Annotation -prettyReport fileContent withUnicode tabSize (Warn code message markers hints) = - prettyReport' fileContent withUnicode tabSize False code message markers hints -prettyReport fileContent withUnicode tabSize (Err code message markers hints) = - prettyReport' fileContent withUnicode tabSize True code message markers hints - -prettyReport' :: - Pretty msg => - FileMap -> - Bool -> - Int -> - Bool -> - Maybe msg -> - msg -> - [(Position, Marker msg)] -> - [Note msg] -> - Doc Annotation -prettyReport' fileContent withUnicode tabSize 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 - - groupedMarkers = groupMarkersPerFile sortedMarkers - -- group markers by the file they appear in, and put `This` markers at the top of the report - - maxLineNumberLength = maybe 3 (max 3 . length . show . fst . end . fst) $ List.safeLast markers - -- if there are no markers, then default to 3, else get the maximum between 3 and the length of the last marker - - header = - annotate - (KindColor isError) - ((if isError then "error" else "warning") - <> maybe emptyDoc (brackets . pretty) code) - in {- - A report is of the form: - (1) []: - (2) --> - (3) | - (4) | - (5) | - (6) | - (7) = - -} - - {- (1) -} header <> colon <+> align (pretty message) - <> {- (2)..(6) -} fold (uncurry (prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength) <$> groupedMarkers) - <> {- (7) -} prettyAllHints hints maxLineNumberLength withUnicode - -------------------------------------------------------------------------------------- ------ INTERNAL STUFF ---------------------------------------------------------------- -------------------------------------------------------------------------------------- - --- | Inserts a given number of character after a 'Doc'ument. -pad :: Int -> Char -> Doc ann -> Doc ann -pad n c d = width d \w -> pretty $ replicate (n - w) c - --- | Creates a "="-prefix for hints at the end of the report. --- --- Pretty printing yields those results: --- --- "@␣␣␣␣␣=␣@" -hintBullet :: - -- | The length of the left space before the bullet. - Int -> - Doc Annotation -hintBullet leftLen = pad leftLen ' ' emptyDoc <+> annotate RuleColor "=" -{-# INLINE hintBullet #-} - --- | Creates a "dot"-prefix for a report line where there is no code. --- --- Pretty printing yields those results: --- --- [with unicode] "@␣␣␣␣␣•␣@" --- [without unicode] "@␣␣␣␣␣:␣@" -dotPrefix :: - -- | The length of the left space before the bullet. - Int -> - -- | Whether to print with unicode characters or not. - Bool -> - Doc Annotation -dotPrefix leftLen withUnicode = pad leftLen ' ' emptyDoc <+> annotate RuleColor (if withUnicode then "•" else ":") -{-# INLINE dotPrefix #-} - --- | Creates a "pipe"-prefix for a report line where there is no code. --- --- Pretty printing yields those results: --- --- [with unicode] "@␣␣␣␣␣│␣@" --- [without unicode] "@␣␣␣␣␣|␣@" -pipePrefix :: - -- | The length of the left space before the pipe. - Int -> - -- | Whether to print with unicode characters or not. - Bool -> - Doc Annotation -pipePrefix leftLen withUnicode = pad leftLen ' ' emptyDoc <+> annotate RuleColor (if withUnicode then "│" else "|") -{-# INLINE pipePrefix #-} - --- | Creates a line-prefix for a report line containing source code --- --- Pretty printing yields those results: --- --- [with unicode] "@␣␣␣3␣│␣@" --- [without unicode] "@␣␣␣3␣|␣@" --- --- Results may be different, depending on the length of the line number. -linePrefix :: - -- | The length of the amount of space to span before the vertical bar. - Int -> - -- | The line number to show. - Int -> - -- | Whether to use unicode characters or not. - Bool -> - Doc Annotation -linePrefix leftLen lineNo withUnicode = - let lineNoLen = length (show lineNo) - in annotate RuleColor $ emptyDoc <+> pad (leftLen - lineNoLen) ' ' emptyDoc <> pretty lineNo <+> if withUnicode then "│" else "|" -{-# INLINE linePrefix #-} - --- | Creates an ellipsis-prefix, when some line numbers are not consecutive. --- --- Pretty printing yields those results: --- --- [with unicode] "@␣␣␣␣␣⋮␣@" --- [without unicode] "@␣␣␣␣...@" -ellipsisPrefix :: - Int -> - Bool -> - Doc Annotation -ellipsisPrefix leftLen withUnicode = pad leftLen ' ' emptyDoc <> annotate RuleColor (if withUnicode then space <> "⋮" else "...") - -groupMarkersPerFile :: - Pretty msg => - [(Position, Marker msg)] -> - [(Bool, [(Position, Marker msg)])] -groupMarkersPerFile [] = [] -groupMarkersPerFile markers = - let markersPerFile = List.foldl' (HashMap.unionWith (<>)) HashMap.empty $ markers <&> \tup@(p, _) -> HashMap.singleton (file p) [tup] - in -- put all markers on the same file together - -- NOTE: it's a shame that `HashMap.unionsWith f = foldl' (HashMap.unionWith f) emptyDoc` does not exist - - onlyFirstToTrue $ putThisMarkersAtTop $ HashMap.elems markersPerFile - where - onlyFirstToTrue = go True [] - - go _ acc [] = reverse acc - go t acc (x : xs) = go False ((t, x) : acc) xs - - putThisMarkersAtTop = List.sortBy \ms1 ms2 -> - if - | any isThisMarker (snd <$> ms1) -> LT - | any isThisMarker (snd <$> ms2) -> GT - | otherwise -> EQ - -prettyPosition :: Position -> Doc Annotation -prettyPosition (Position (l, c) _ file) = pretty file <> colon <> pretty l <> colon <> pretty c - --- | Prettyprint a sub-report, which is a part of the report spanning across a single file -prettySubReport :: - Pretty msg => - -- | The content of files in the diagnostics - FileMap -> - -- | Is the output done with Unicode characters? - Bool -> - -- | Is the current report an error report? - Bool -> - -- | The number of spaces each TAB character will span - Int -> - -- | The size of the biggest line number - Int -> - -- | Is this sub-report the first one in the list? - Bool -> - -- | The list of line-ordered markers appearing in a single file - [(Position, Marker msg)] -> - Doc Annotation -prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength isFirst markers = - let (markersPerLine, multilineMarkers) = splitMarkersPerLine markers - -- split the list on whether markers are multiline or not - - sortedMarkersPerLine = {- second (List.sortOn (first $ snd . begin)) <$> -} List.sortOn fst (HashMap.toList markersPerLine) - - reportFile = prettyPosition $ maybe def fst $ List.safeHead (List.sortOn (Down . snd) markers) - -- the reported file is the file of the first 'This' marker (only one must be present) - - allLineNumbers = List.sort $ List.nub $ (fst <$> sortedMarkersPerLine) <> (multilineMarkers >>= \(Position (bl, _) (el, _) _, _) -> [bl .. el]) - - fileMarker = - space <> pad maxLineNumberLength ' ' emptyDoc - <+> annotate RuleColor (if withUnicode then "┌─" else "-->") - <+> annotate FileColor reportFile - in {- (2) -} hardline <> fileMarker <> hardline - <+> {- (3) -} pipePrefix maxLineNumberLength withUnicode - <> {- (4) -} prettyAllLines fileContent withUnicode isError tabSize maxLineNumberLength sortedMarkersPerLine multilineMarkers allLineNumbers - -isThisMarker :: Marker msg -> Bool -isThisMarker (This _) = True -isThisMarker _ = False - --- | -splitMarkersPerLine :: [(Position, Marker msg)] -> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)]) -splitMarkersPerLine [] = (HashMap.empty, []) -splitMarkersPerLine (m@(Position {..}, _) : ms) = - let (bl, _) = begin - (el, _) = end - in (if bl == el then first (HashMap.insertWith (<>) bl [m]) else second (m :)) - (splitMarkersPerLine 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] -> - 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 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 emptyDoc) - <> prettyAllLines files withUnicode isError tabSize leftLen inline ms (l2 : ls) - where - showForLine isLastLine line = - {- - A line of code is composed of: - (1) | - (2) | - - Multline markers may further indent the code: - (1) │ ╭ - (2) │ │ - │ │ ╭ - │ │ │ - (3) · │ │ - │ │ │ - (4) │ │ ╰' - │ │ else - (5) │ ╰───^ - -} - let allInlineMarkersInLine = snd =<< filter ((==) line . fst) inline - - allMultilineMarkersInLine = flip filter multiline \(Position (bl, _) (el, _) _, _) -> bl == line || el == line - - allMultilineMarkersSpanningLine = flip filter multiline \(Position (bl, _) (el, _) _, _) -> bl < line && el > line - - inSpanOfMultiline = flip any multiline \(Position (bl, _) (el, _) _, _) -> bl <= line && el >= line - - colorOfFirstMultilineMarker = maybe id (annotate . markerColor isError . snd) (List.safeHead $ allMultilineMarkersInLine <> allMultilineMarkersSpanningLine) - -- take the first multiline marker to color the entire line, if there is one - - (multilineEndingOnLine, otherMultilines) = flip List.partition multiline \(Position _ (el, _) _, _) -> el == line - - !additionalPrefix = case allMultilineMarkersInLine of - [] -> - if not $ null multiline - then - if not $ null allMultilineMarkersSpanningLine - then colorOfFirstMultilineMarker if withUnicode then "│ " else "| " - else " " - else emptyDoc - (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 ">") - <> space - - -- we need to remove all blank markers because they are irrelevant to the display - allInlineMarkersInLine' = filter ((/=) Blank . snd) allInlineMarkersInLine - allMultilineMarkersSpanningLine' = filter ((/=) Blank . snd) allMultilineMarkersSpanningLine - - (widths, renderedCode) = getLine_ files (allInlineMarkersInLine <> allMultilineMarkersInLine <> allMultilineMarkersSpanningLine') line tabSize isError - in ( otherMultilines, - hardline - <> {- (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 - ) - - showMultiline _ [] = emptyDoc - showMultiline isLastMultiline 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 - - prefix = hardline <+> dotPrefix leftLen withUnicode <> space - - prefixWithBar color = prefix <> maybe id annotate color (if withUnicode then "│ " else "| ") - - showMultilineMarkerMessage (_, Blank) _ = emptyDoc - showMultilineMarkerMessage (_, marker) isLast = - 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) (pretty $ 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) - --- | -getLine_ :: - FileMap -> - [(Position, Marker msg)] -> - Int -> - Int -> - Bool -> - (WidthTable, Doc Annotation) -getLine_ files markers line tabSize isError = - case safeArrayIndex (line - 1) =<< (HashMap.!?) files . file . fst =<< List.safeHead markers of - Nothing -> - ( mkWidthTable "", - annotate NoLineColor "" - ) - Just code -> - ( mkWidthTable code, - flip foldMap (zip [1 ..] code) \(n, c) -> - let cdoc = ifTab (pretty (replicate tabSize ' ')) pretty c - colorizingMarkers = flip filter markers \case - (Position (bl, bc) (el, ec) _, _) - | bl == el -> - n >= bc && n < ec - | otherwise -> - (bl == line && n >= bc) - || (el == line && n < ec) - || (bl < line && el > line) - in maybe - (annotate CodeStyle) - ((\m -> annotate (MarkerStyle $ markerColor isError m)) . snd) - (List.safeHead colorizingMarkers) - cdoc - ) - where - ifTab :: a -> (Char -> a) -> Char -> a - ifTab a _ '\t' = a - ifTab _ f c = f c - - mkWidthTable :: String -> WidthTable - mkWidthTable s = listArray (1, length s) (ifTab tabSize wcwidth <$> s) - - wcwidth :: Char -> Int - wcwidth c@(W.wcwidth -> w) - | w >= 0 = w - | otherwise = error (printf "negative width for '%c' (0x%04x)" c (ord c)) - --- | -showAllMarkersInLine :: Pretty msg => Bool -> Bool -> (Doc Annotation -> Doc Annotation) -> Bool -> Bool -> Int -> WidthTable -> [(Position, Marker msg)] -> Doc Annotation -showAllMarkersInLine _ _ _ _ _ _ _ [] = emptyDoc -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 = emptyDoc - 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 emptyDoc else specialPrefix <> showMarkers 1 maxMarkerColumn <> showMessages specialPrefix ms maxMarkerColumn) - where - widthAt i = 0 `fromMaybe` safeArrayIndex i widths - widthsBetween start end = - sum $ take (end - start) $ drop (start - 1) $ Array.elems widths - - showMarkers n lineLen - | n > lineLen = emptyDoc -- reached the end of the line - | otherwise = - let allMarkers = flip filter ms \(Position (_, bc) (_, ec) _, mark) -> mark /= Blank && n >= bc && n < ec - in -- only consider markers which span onto the current column - case allMarkers of - [] -> fold (replicate (widthAt n) space) <> showMarkers (n + 1) lineLen - (Position {..}, marker) : _ -> - 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 "-") - ) - <> showMarkers (n + 1) lineLen - - showMessages specialPrefix ms lineLen = case List.safeUncons ms of - Nothing -> emptyDoc -- no more messages to show - Just ((Position b@(_, bc) _ _, msg), pipes) -> - let filteredPipes = filter (uncurry (&&) . bimap ((/= b) . begin) (/= Blank)) pipes - -- record only the pipes corresponding to markers on different starting positions - nubbedPipes = List.nubBy ((==) `on` (begin . fst)) filteredPipes - -- and then remove all duplicates - - allColumns _ [] = (1, []) - allColumns n ms@((Position (_, bc) _ _, col) : ms') - | n == bc = bimap (+ 1) (col :) (allColumns (n + 1) ms') - | n < bc = bimap (+ 1) (replicate (widthAt n) space <>) (allColumns (n + 1) ms) - | otherwise = bimap (+ 1) (replicate (widthAt n) space <>) (allColumns (n + 1) ms') - -- transform the list of remaining markers into a single document line - - hasSuccessor = length filteredPipes /= length pipes - - 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 ' ') - -- 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 "|") - -- pre-render pipes which are before because they will be shown - - lastBeginPosition = snd . begin . fst <$> List.safeLast (List.sortOn (snd . begin . fst) pipesAfter) - - lineLen = case lastBeginPosition of - Nothing -> 0 - Just col -> widthsBetween bc col - - currentPipe = - if - | withUnicode && hasSuccessor -> "├" - | withUnicode -> "╰" - | hasSuccessor -> "|" - | otherwise -> "`" - - lineChar = if withUnicode then '─' else '-' - pointChar = if withUnicode then "╸" else "-" - - 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 "|") - 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) - in hardline <+> prefix <> showMessages specialPrefix pipes lineLen - --- WARN: uses the internal of the library 'prettyprinter' --- --- 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 repl (Char '\n') = repl -replaceLinesWith _ (Char c) = Char c -replaceLinesWith repl (Text _ s) = - let lines = Text.split (== '\n') s <&> \txt -> Text (Text.length txt) txt - in mconcat (List.intersperse repl lines) -replaceLinesWith repl (FlatAlt f d) = FlatAlt (replaceLinesWith repl f) (replaceLinesWith repl d) -replaceLinesWith repl (Cat c d) = Cat (replaceLinesWith repl c) (replaceLinesWith repl d) -replaceLinesWith repl (Nest n d) = Nest n (replaceLinesWith repl d) -replaceLinesWith repl (Union c d) = Union (replaceLinesWith repl c) (replaceLinesWith repl d) -replaceLinesWith repl (Column f) = Column (replaceLinesWith repl . f) -replaceLinesWith repl (Nesting f) = Nesting (replaceLinesWith repl . f) -replaceLinesWith repl (Annotated ann doc) = Annotated ann (replaceLinesWith repl doc) -replaceLinesWith repl (WithPageWidth f) = WithPageWidth (replaceLinesWith repl . f) - --- | Extracts the color of a marker as a 'Doc' coloring function. -markerColor :: - -- | Whether the marker is in an error context or not. - -- This really makes a difference for a 'This' marker. - Bool -> - -- | The marker to extract the color from. - Marker msg -> - -- | A function used to color a 'Doc'. - Annotation -markerColor isError (This _) = ThisColor isError -markerColor _ (Where _) = WhereColor -markerColor _ (Maybe _) = MaybeColor -markerColor _ Blank = CodeStyle -- we take the same color as the code, for it to be invisible -{-# INLINE markerColor #-} - --- | Retrieves the message held by a marker. -markerMessage :: Marker msg -> msg -markerMessage (This m) = m -markerMessage (Where m) = m -markerMessage (Maybe m) = m -markerMessage Blank = undefined -{-# INLINE markerMessage #-} - --- | Pretty prints all hints. -prettyAllHints :: Pretty msg => [Note msg] -> Int -> Bool -> Doc Annotation -prettyAllHints [] _ _ = emptyDoc -prettyAllHints (h : hs) leftLen withUnicode = - {- - A hint is composed of: - (1) = hint: - -} - let prefix = hardline <+> hintBullet leftLen - in prefix <+> annotate HintColor (notePrefix h <+> pretty (noteMessage h)) - <> prettyAllHints hs leftLen withUnicode - where - notePrefix (Note _) = "note:" - notePrefix (Hint _) = "hint:" - - noteMessage (Note msg) = msg - noteMessage (Hint msg) = msg - -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 From 0e35e0520d674361c48e93bd4bfb9751f0947efb Mon Sep 17 00:00:00 2001 From: Ruifeng Xie Date: Tue, 13 Sep 2022 20:14:54 +0800 Subject: [PATCH 04/10] secondary labels should not colour the source --- .../Diagnose/Layout/CodeSpanReporting.hs | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs index 2d64e81..d8ccbbd 100644 --- a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs +++ b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs @@ -37,12 +37,13 @@ defaultStyle = reAnnotate \case R.SourceBorder -> colorDull Cyan -- Blue R.NoteBullet -> colorDull Cyan -- Blue R.LineNumber -> colorDull Cyan -- Blue - R.SourceTint sev sty -> marker sev sty - R.MarkerTint sev sty -> marker sev sty - where marker R.Bug R.SThis = colorDull Red - marker R.Error R.SThis = colorDull Red - marker R.Warning R.SThis = colorDull Yellow - marker R.Note R.SThis = colorDull Green - marker R.Help R.SThis = colorDull Cyan - marker _ R.SBlank = mempty - marker _ _ = colorDull Cyan -- Blue + R.SourceTint sev sty -> marker sev sty True + R.MarkerTint sev sty -> marker sev sty False + where marker R.Bug R.SThis _ = colorDull Red + marker R.Error R.SThis _ = colorDull Red + marker R.Warning R.SThis _ = colorDull Yellow + marker R.Note R.SThis _ = colorDull Green + marker R.Help R.SThis _ = colorDull Cyan + marker _ R.SBlank _ = mempty + marker _ _ True = colorDull White + marker _ _ False = colorDull Cyan -- Blue From 24fffa0bdb1678dd6186f78a1aec3181b285ba91 Mon Sep 17 00:00:00 2001 From: Ruifeng Xie Date: Tue, 13 Sep 2022 20:44:16 +0800 Subject: [PATCH 05/10] remove import of Debug.Trace --- .../src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs index 76fb348..5c955bd 100644 --- a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs +++ b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs @@ -27,7 +27,6 @@ import qualified Error.Diagnose as E (Note(Note, Hint)) import Error.Diagnose.Layout (FileMap) import Prettyprinter (Doc, Pretty(..), (<+>), annotate, brackets, emptyDoc, colon, space, hardline, column, fill) import Prettyprinter.Internal (Doc(..)) -import Debug.Trace (traceShowId) unicodeWidth :: Int -> Int -> Char -> Int unicodeWidth tabSize col c@(wcwidth -> w) From b69ae8c73e50dcee109680c45d45de646bff6785 Mon Sep 17 00:00:00 2001 From: Ruifeng Xie Date: Sat, 15 Oct 2022 21:14:05 +0800 Subject: [PATCH 06/10] clean up Error.Diagnose.CodeSpanReporting.Render & add docs --- .../Layout/CodeSpanReporting/Render.hs | 245 ++++++++++++++---- 1 file changed, 191 insertions(+), 54 deletions(-) diff --git a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs index 5c955bd..3619197 100644 --- a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs +++ b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs @@ -1,32 +1,35 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DerivingVia #-} module Error.Diagnose.Layout.CodeSpanReporting.Render where import Error.Diagnose.Layout.CodeSpanReporting.Config -import qualified Data.Array.IArray as A (array, bounds, (!)) +import qualified Data.Array.IArray as A (Array, array, bounds, (!)) import qualified Data.HashMap.Lazy as H ((!?)) +import qualified Data.List.NonEmpty as N (cons, head, singleton, toList) import qualified Data.Text as T (length, split) + +import Control.Arrow ((&&&)) import Data.Array.Unboxed (UArray) +import Data.Bifunctor (bimap, second) import Data.Char (isSpace, ord) import Data.Char.WCWidth (wcwidth) import Data.Foldable (maximumBy) import Data.Function (on) -import Data.List (groupBy, nub, sort, sortOn, dropWhileEnd, intersperse) -import Data.Maybe (isJust, fromJust) +import Data.List (dropWhileEnd, groupBy, intersperse, nub, sort, sortOn, uncons, unfoldr) +import Data.Maybe (fromJust, isJust) import Data.Ord (comparing) -import Control.Arrow ((&&&)) import Text.Printf (printf) -import Error.Diagnose (Position(..), Marker(..), Report(..), Note, align, hsep) -import qualified Error.Diagnose as E (Note(Note, Hint)) +import qualified Error.Diagnose as E (Note (Hint, Note)) + +import Error.Diagnose (Marker (..), Note, Position (..), Report (..), align, hsep) import Error.Diagnose.Layout (FileMap) -import Prettyprinter (Doc, Pretty(..), (<+>), annotate, brackets, emptyDoc, colon, space, hardline, column, fill) -import Prettyprinter.Internal (Doc(..)) +import Prettyprinter (Doc, Pretty (..), annotate, brackets, colon, column, emptyDoc, fill, hardline, space, (<+>)) +import Prettyprinter.Internal (Doc (..)) unicodeWidth :: Int -> Int -> Char -> Int unicodeWidth tabSize col c@(wcwidth -> w) @@ -94,6 +97,61 @@ takeNAndOthers n (first : rest) = pretty first <> go (pred n) rest go 0 others = ", and " <> pretty (length others) <> " other(s)" go k (x : xs) = ", " <> pretty x <> go (pred k) xs +{- + Basic Common Types + ================== + + These should be self-documenting. + Note that 'Line', 'Colomn', 'Range', etc. are all type synonyms only. +-} + +type Line = Int +type Column = Int +type Range a = (a, a) + +inRange :: Ord a => a -> Range a -> Bool +x `inRange` (l, r) = l <= x && x <= r + +isOverlapping :: Ord a => Range a -> Range a -> Bool +isOverlapping (l1, r1) (l2, r2) = r1 >= l2 && r2 >= l1 + +combineRange :: Ord a => Range a -> Range a -> Range a +combineRange (l1, r1) (l2, r2) = (min l1 l2, max r1 r2) + +type SingleMarker msg = (Range Column, Marker msg) +type MultiMarker msg = (Range (Line, Column), Marker msg) + +linesForMulti :: MultiMarker msg -> [Line] +linesForMulti (((lnS, _), (lnE, _)), _) = [lnS, lnE] + +linesForMultis :: [MultiMarker msg] -> [Line] +linesForMultis = nub . sort . concatMap linesForMulti + +{- + Overall Process + =============== + + 1. Classify single-line and multi-line markers + + - Single-line markers: @(Line, (Range Column, Marker msg))@ + - Multi-line markers: @(Range (Line, Column), Marker msg)@ + + 2. Group multi-line markers into disjoint groups + + - @(_, (ln1E, _))@ and @((ln2S, _), _)@ are "disjoint" iff @ln1E < ln2S@ + - Each group of multi-line markers can be laid out separately + + 3. Extract lines of interest + + - start and end lines of multi-line markers + - lines of single-line markers + - padding lines: existence of @n@ and @n + 2@ implies existence of @n@ + + 4. Associate each line with its single-line markers and multi-line markers in its group (determined in 2) + + 5. Render each line with the associated markers +-} + report :: Pretty msg => FileMap -> Chars -> Int -> Report msg -> Doc Annotation report fileMap chars@Chars{ cNoteBullet, cSourceBorderLeft } tabSize (reportComponents -> (sev, code, msg, markers, notes)) @@ -109,31 +167,20 @@ report fileMap chars@Chars{ cNoteBullet, cSourceBorderLeft } . groupBy ((==) `on` file . fst) . sortOn (posToTriple . fst) posToTriple Position{ begin, end, file } = (file, begin, end) - renderFile (fileName, thisMarkers@(classifyMarkers -> (groupSingles -> singleWithLines, multis))) + renderFile (fileName, thisMarkers) | Just fileLines <- fileMap H.!? fileName - , missingLines <- filter (not . (`inRange` A.bounds fileLines) . pred) lineNumbers - = if null missingLines then - let go (b, ln, singles) = sourceLine chars tabSize b ln maxLnWidth (fileLines A.! pred ln) sev singles multis - in snippetStart chars maxLnWidth startPos <> foldMap go allLines <> trailingLeftBorder + , let (singles, multis) = classifyAndGroupMarkers fileLines thisMarkers + , let markedLines = linesOfInterest fileLines singles multis + , let maxMultiCount = maximum (0 : map (length . nonBlank . snd) multis) + , let missingLines = filter (not . (`inRange` A.bounds fileLines) . pred) allLines + , let go = sourceLine chars tabSize maxLnWidth maxMultiCount sev + = if null missingLines + then snippetStart chars maxLnWidth startPos <> foldMap go markedLines <> trailingLeftBorder else makeBug ("line " <> takeNAndOthers 2 missingLines <> " of file '" <> pretty fileName <> "' not available") | otherwise = makeBug ("content of file '" <> pretty fileName <> "' not available") - where lineNumbers = map fst singleWithLines ++ concatMap linesForMulti multis - allLines = fillGap $ merge singleWithLines $ nub $ sort $ concatMap linesForMulti multis - merge [] ys = map (, []) ys - merge xs [] = xs - merge (x : xs) (y : ys) = case compare (fst x) y of - LT -> x : merge xs (y : ys) - EQ -> x : merge xs ys - GT -> (y, []) : merge (x : xs) ys - fillGap ((lnX, x) : xs@((lnY, _) : _)) - | lnX + 1 == lnY = (True, lnX, x) : fillGap xs - | lnX + 2 == lnY = (True, lnX, x) : (True, succ lnX, []) : fillGap xs - | otherwise = (True, lnX, x) : (False, succ lnX, []) : fillGap xs - fillGap xs = map (\(ln, t) -> (True, ln, t)) xs - linesForMulti (((lnS, _), (lnE, _)), _) = [lnS, lnE] + where allLines = nub $ sort $ concatMap (\(Position{..}, _) -> [fst begin, fst end]) thisMarkers startPos = fst (head thisMarkers) makeBug s = leftPadding <+> annotate (Header Bug) "bug" <> annotate HeaderMessage (colon <+> s) <> hardline - groupSingles = map (fst . head &&& map snd) . groupBy ((==) `on` fst) renderNote nt -- ' = : ' = leftPadding <+> annotate NoteBullet (pretty cNoteBullet) @@ -147,11 +194,113 @@ partitionEither p = foldr go ([], []) where go (p -> Left b) ~(bs, cs) = (b : bs, cs) go (p -> Right c) ~(bs, cs) = (bs, c : cs) +-- | 1. Classify single-line and multi-line markers classifyMarkers :: [(Position, Marker msg)] -> ([(Line, SingleMarker msg)], [MultiMarker msg]) classifyMarkers = partitionEither \(pos, marker) -> let Position{ begin = begin@(lnS, colS), end = end@(lnE, colE) } = pos in if lnS == lnE then Left (lnS, ((colS, colE), marker)) else Right ((begin, end), marker) +classifyAndGroupMarkers :: A.Array Int String -> [(Position, Marker msg)] -> ([(Line, [SingleMarker msg])], [MultiGroup msg]) +classifyAndGroupMarkers fileLines = bimap groupSingles (groupMultis fileLines) . classifyMarkers + +-- | 2. Group multi-line markers into disjoint groups +-- +-- Note: The input is expected to be sorted, but we cannot use 'groupBy' because it gives incorrect semantics. +groupMultis :: A.Array Int String -> [MultiMarker msg] -> [MultiGroup msg] +groupMultis fileLines = map (second N.toList) . foldr combine [] . scanlAndLabel label (-1) -- go (-1) + where label maxSoFar this = maxSoFar `max` endLine this + combine (_, this) [] = [(lineRange this, N.singleton this)] + combine (maxE, this) res@((rng, g) : rest) + -- decide: whether group [.. this] overlaps with the next one + -- overlapping, push 'this' onto the group (starting with 'this') + | lnS < maxE || (lnS == maxE && colS <= leadingSpaces) + = (combineRange thisRng rng, N.cons this g) : rest + -- not overlapping, start a new group (ending with 'this') + -- note: we have already sorted the markers, + | otherwise = (thisRng, N.singleton this) : res + where thisRng = lineRange this + lnS = startLine (N.head g) + colS = startCol (N.head g) + text = fileLines A.! pred lnS + leadingSpaces = length (takeWhile isSpace text) + -- go _ [] = [] + -- go lnM (this : rest) + -- | g : gs <- res, startLine g < lnM = res' + -- | g : gs <- res, startLine g == lnM = (rng, [this]) : res' + -- | otherwise = (rng, [this]) : res + -- where rng@(_, lnE) = lineRange this + -- startLine ((lnS, _), _) = lnS + -- lnM' = lnM `max` lnE + -- res = go lnM' rest + -- res' = bimap (combineRange (lineRange this)) (this :) g : gs + lineRange (((lnS, _), (lnE, _)), _) = (lnS, lnE) + startCol (((_, colS), _), _) = colS + startLine = fst . lineRange + endLine = snd . lineRange + +scanlAndLabel :: (b -> a -> b) -> b -> [a] -> [(b, a)] +scanlAndLabel f e0 = unfoldr go . (e0, ) + where go (_, []) = Nothing + go (e, x : xs) = let e' = f e x in Just ((e', x), (e', xs)) + +type MultiGroup msg = (Range Line, [MultiMarker msg]) + +linesForMultiGroups :: [MultiGroup msg] -> [Line] +linesForMultiGroups = nub . concatMap (nub . sort . concatMap linesForMulti . snd) + +groupSingles :: [(Line, SingleMarker msg)] -> [(Line, [SingleMarker msg])] +groupSingles = map (fst . head &&& map snd) . groupBy ((==) `on` fst) + +-- | 3. Extract lines of interest +-- 4. Associate each line with its single-line markers and multi-line markers in its group (determined in 2) +-- +-- note: 'error' if there are missing lines. Check before use. +linesOfInterest :: A.Array Int String -> [(Line, [SingleMarker msg])] -> [MultiGroup msg] -> [MarkedLine msg] +linesOfInterest fileLines singles multiGroups = unfoldr go (theLines, multiGroups) + where theLines = fillGap (mergeMarkers singles (linesForMultiGroups multiGroups)) + go ([], _) = Nothing + go (ls, []) = go (ls, [((maxBound, maxBound), [])]) + go (ls@(l : ls'), gs@(((lnS, lnE), nonBlank -> multiMarkers) : gs')) + | lineNumber < lnS = Just (MarkedLine{multiMarkers = [], nextMarkers = multiMarkers, ..}, (ls', gs)) + | lineNumber > lnE = go (ls, gs') + | otherwise = Just (MarkedLine{..}, (ls', gs)) + where (isRealSource, lineNumber, nonBlank -> singleMarkers) = l + lineText = fileLines A.! pred lineNumber + nextMarkers = maybe [] (nonBlank . snd . fst) (uncons gs') + +data MarkedLine msg = MarkedLine + { isRealSource :: !Bool + , lineNumber :: {-# UNPACK #-} !Line + , lineText :: String + , singleMarkers :: [SingleMarker msg] + , multiMarkers :: [MultiMarker msg] + , nextMarkers :: [MultiMarker msg] + } + +mergeMarkers :: [(Line, [SingleMarker msg])] -> [Line] -> [(Line, [SingleMarker msg])] +mergeMarkers [] ys = map (, []) ys +mergeMarkers xs [] = xs +mergeMarkers (x : xs) (y : ys) = case compare (fst x) y of + LT -> x : mergeMarkers xs (y : ys) + EQ -> x : mergeMarkers xs ys + GT -> (y, []) : mergeMarkers (x : xs) ys + +fillGap :: [(Line, [SingleMarker msg])] -> [(Bool, Line, [SingleMarker msg])] +fillGap ((lnX, x) : xs@((lnY, _) : _)) + | lnX + 1 == lnY = (True, lnX, x) : fillGap xs + | lnX + 2 == lnY = (True, lnX, x) : (True, succ lnX, []) : fillGap xs + | otherwise = (True, lnX, x) : (False, succ lnX, []) : fillGap xs +fillGap xs = map (\(ln, t) -> (True, ln, t)) xs + +{- + Report structure + ================ + + 1. One header (severity, error code, and message) + 2. One sub-report for each mentioned file + 3. Notes and helps attached to this report +-} + header :: Pretty msg => Severity -> Maybe msg -> msg -> Doc Annotation header sev code msg -- header: 'error[E0001]' @@ -172,20 +321,7 @@ padWith w t f = pretty (replicate (w - length t) ' ') <> f (pretty t) pad :: Int -> String -> Doc ann pad w t = padWith w t id -type Line = Int -type Column = Int -type Range a = (a, a) - -inRange :: Ord a => a -> Range a -> Bool -x `inRange` (l, r) = l <= x && x <= r - -isOverlapping :: Ord a => Range a -> Range a -> Bool -isOverlapping (l1, r1) (l2, r2) = r1 >= l2 && r2 >= l1 - -type SingleMarker msg = (Range Column, Marker msg) -type MultiMarker msg = (Range (Line, Column), Marker msg) - --- note: we allow a one-pass-the-end index (to allow place a caret here) +-- note: we allow a one-pass-the-end index (to allow placing a caret here) mkWidthTable :: Int -> String -> UArray Int Int mkWidthTable tabSize s = A.array (1, length s + 1) $ zip [1..] $ scanl go 0 s where go n c = n + unicodeWidth tabSize n c @@ -207,16 +343,14 @@ sourceLine :: Pretty msg => Chars -> Int -- ^ tab size. - -> Bool -- ^ 'True' - real source line; 'False' - gap. - -> Int -- ^ line number. -> Int -- ^ width for the line number. - -> String -- ^ source code. + -> Int -- ^ maximum number of multi-line markers. -> Severity -- ^ severity of the message for this line. - -> [SingleMarker msg] -- single-line markers. - -> [MultiMarker msg] -- multi-line markers. + -> MarkedLine msg -> Doc Annotation -sourceLine Chars{..} tabSize isRealSource ln lnWidth - (trimEnd -> text) sev (nonBlank -> singles) (nonBlank -> multis) +sourceLine Chars{..} tabSize lnWidth maxMultiCount sev + MarkedLine{ isRealSource, lineNumber = ln, lineText = (trimEnd -> text) + , singleMarkers = singles, multiMarkers = multis, nextMarkers } -- > 10 │ │ muffin. Halvah croissant candy canes bonbon candy. Apple pie jelly = headLeader <+> attachColour text <> hardline -- > │ │ ^^^^^^ -------^^^^^^^^^-------^^^^^------- ^^^^^ trailing label message @@ -231,12 +365,14 @@ sourceLine Chars{..} tabSize isRealSource ln lnWidth <> drawDanglingMsgs (pred nDanglingMsgs)) -- > │ ╭─│─────────^ <> foldMap renderMultiTopBottom (indexed multis) + <> foldMap renderMultiTopBottom (indexed nextMarkers) where + paddingForMultis = pad (2 * (maxMultiCount - length multis)) "" headLeader = lineNumber <+> leaders True tailLeader = pad lnWidth "" <+> leaders False lineNumber = if isRealSource then padWith lnWidth (show ln) (annotate LineNumber) else pad lnWidth "" -- handle leading multi-line markers - leaders isSource = border <+> hsep (map (leadingMarker isSource) multis) + leaders isSource = border <+> paddingForMultis <> hsep (map (leadingMarker isSource) multis) border = annotate SourceBorder (pretty if isRealSource then cSourceBorderLeft else cSourceBorderLeftBreak) leadingMarker isSource (((lnS, colS), (lnE, _)), markerStyle -> st) | lnS == ln, colS <= leadingSpaces, isSource = ann (pretty cMultiTopLeft) @@ -317,7 +453,7 @@ sourceLine Chars{..} tabSize isRealSource ln lnWidth | lnE == ln = multiLeader True <> ann outerSt (replicate (pred colE) cMultiBottom ++ [ed]) <+> pMsg <> hardline | isStart = multiLeader True <> ann outerSt (replicate (pred colS) cMultiTop ++ [st]) <> hardline | otherwise = emptyDoc - where leader = pad lnWidth "" <+> border + where leader = pad lnWidth "" <+> border <> paddingForMultis multiLeader isMain = leader <+> foldMap (multiMarkerLeft isMain) (indexed multis) isStart = lnS == ln && colS > leadingSpaces cBar = if isStart then cMultiTop else cMultiBottom @@ -342,8 +478,9 @@ sourceLine Chars{..} tabSize isRealSource ln lnWidth trim, trimStart, trimEnd :: String -> String trim = trimStart . trimEnd -trimStart = dropWhile isSpace +trimStart = dropWhile isSpace trimEnd = dropWhileEnd isSpace + -- WARN: uses the internal of the library 'prettyprinter' -- -- DO NOT use a wildcard here, in case the internal API exposes one more constructor From 6d2c639a8ed9f584c15ccc4a5372b0c489288482 Mon Sep 17 00:00:00 2001 From: Ruifeng Xie Date: Sat, 15 Oct 2022 21:38:08 +0800 Subject: [PATCH 07/10] =?UTF-8?q?use=20rustc-like=20ruler=20chars=20-=20'?= =?UTF-8?q?=5F'=20instead=20of=20'-'=20for=20top/bottom=20rules=20-=20get?= =?UTF-8?q?=20rid=20of=20=E2=80=98/=E2=80=99=20and=20'\'=20at=20the=20corn?= =?UTF-8?q?ers=20(IMO=20they=20look=20ugly)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../src/Error/Diagnose/Layout/CodeSpanReporting/Config.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Config.hs b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Config.hs index 1303bc6..edd0c80 100644 --- a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Config.hs +++ b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Config.hs @@ -83,10 +83,10 @@ asciiChars = Chars , cMultiPrimaryCaretEnd = '^' , cMultiSecondaryCaretStart = '\'' , cMultiSecondaryCaretEnd = '\'' - , cMultiTopLeft = '/' - , cMultiTop = '-' - , cMultiBottomLeft = '\\' - , cMultiBottom = '-' + , cMultiTopLeft = ' ' + , cMultiTop = '_' + , cMultiBottomLeft = '|' + , cMultiBottom = '_' , cMultiLeft = '|' , cPointerLeft = '|' } From c2e92a1b321cca5addeb3e8c8ed613db5e572059 Mon Sep 17 00:00:00 2001 From: Ruifeng Xie Date: Sat, 15 Oct 2022 21:39:17 +0800 Subject: [PATCH 08/10] remove unused code in comments --- .../Error/Diagnose/Layout/CodeSpanReporting/Render.hs | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs index 3619197..e2a5dc6 100644 --- a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs +++ b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs @@ -223,16 +223,6 @@ groupMultis fileLines = map (second N.toList) . foldr combine [] . scanlAndLabel colS = startCol (N.head g) text = fileLines A.! pred lnS leadingSpaces = length (takeWhile isSpace text) - -- go _ [] = [] - -- go lnM (this : rest) - -- | g : gs <- res, startLine g < lnM = res' - -- | g : gs <- res, startLine g == lnM = (rng, [this]) : res' - -- | otherwise = (rng, [this]) : res - -- where rng@(_, lnE) = lineRange this - -- startLine ((lnS, _), _) = lnS - -- lnM' = lnM `max` lnE - -- res = go lnM' rest - -- res' = bimap (combineRange (lineRange this)) (this :) g : gs lineRange (((lnS, _), (lnE, _)), _) = (lnS, lnE) startCol (((_, colS), _), _) = colS startLine = fst . lineRange From dfd00ebe81a1b7e411fef34d5810f79f39938ea2 Mon Sep 17 00:00:00 2001 From: Ruifeng Xie Date: Sun, 16 Oct 2022 16:00:04 +0800 Subject: [PATCH 09/10] support rich notes/hints --- .../Diagnose/Layout/CodeSpanReporting.hs | 38 ++-- .../Layout/CodeSpanReporting/Config.hs | 50 +++-- .../Layout/CodeSpanReporting/Render.hs | 200 +++++++++++++----- 3 files changed, 198 insertions(+), 90 deletions(-) diff --git a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs index d8ccbbd..830edff 100644 --- a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs +++ b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs @@ -4,7 +4,7 @@ import Error.Diagnose.Diagnostic (filesOf, reportsOf) import Error.Diagnose.Layout (Layout) import Error.Diagnose.Style (Style, reAnnotate) -import Error.Diagnose (bold, color, Color(..), colorDull) +import Error.Diagnose (Color (..), bold, color, colorDull) import qualified Error.Diagnose.Layout.CodeSpanReporting.Config as R import qualified Error.Diagnose.Layout.CodeSpanReporting.Render as R @@ -28,22 +28,24 @@ codespanReportingLayout withUnicode tabSize diag defaultStyle :: Style R.Annotation defaultStyle = reAnnotate \case - R.Header R.Bug -> bold <> color Red - R.Header R.Error -> bold <> color Red - R.Header R.Warning -> bold <> color Yellow - R.Header R.Note -> bold <> color Green - R.Header R.Help -> bold <> color Cyan - R.HeaderMessage -> bold <> color White - R.SourceBorder -> colorDull Cyan -- Blue - R.NoteBullet -> colorDull Cyan -- Blue - R.LineNumber -> colorDull Cyan -- Blue + R.Header R.Bug -> bold <> color Red + R.Header R.Error -> bold <> color Red + R.Header R.Warning -> bold <> color Yellow + R.Header R.Note -> bold <> color Green + R.Header R.Help -> bold <> color Cyan + R.HeaderMessage -> bold <> color White + R.SourceBorder -> colorDull Cyan -- Blue + R.NoteBullet -> colorDull Cyan -- Blue + R.LineNumber -> colorDull Cyan -- Blue R.SourceTint sev sty -> marker sev sty True R.MarkerTint sev sty -> marker sev sty False - where marker R.Bug R.SThis _ = colorDull Red - marker R.Error R.SThis _ = colorDull Red - marker R.Warning R.SThis _ = colorDull Yellow - marker R.Note R.SThis _ = colorDull Green - marker R.Help R.SThis _ = colorDull Cyan - marker _ R.SBlank _ = mempty - marker _ _ True = colorDull White - marker _ _ False = colorDull Cyan -- Blue + where marker R.Bug R.SPrimary _ = colorDull Red + marker R.Error R.SPrimary _ = colorDull Red + marker R.Warning R.SPrimary _ = colorDull Yellow + marker R.Note R.SPrimary _ = colorDull Green + marker R.Help R.SPrimary _ = colorDull Cyan + marker _ R.SBlank _ = mempty + marker _ R.SAdd _ = color Green + marker _ R.SRemove _ = color Red + marker _ R.SSecondary True = colorDull White + marker _ R.SSecondary False = colorDull Cyan -- Blue diff --git a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Config.hs b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Config.hs index edd0c80..a8bd190 100644 --- a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Config.hs +++ b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Config.hs @@ -3,52 +3,64 @@ module Error.Diagnose.Layout.CodeSpanReporting.Config where data Chars = Chars -- | The characters to use for the top-left border of the snippet. -- Defaults to: @┌─@ or @-->@ with asciiChars. - { cSnippetStart :: String + { cSnippetStart :: String -- | The character to use for the left border of the source. -- Defaults to: @│@ or @|@ with asciiChars. - , cSourceBorderLeft :: Char + , cSourceBorderLeft :: Char -- | The character to use for the left border break of the source. -- Defaults to: @·@ or @.@ with asciiChars. - , cSourceBorderLeftBreak :: Char + , cSourceBorderLeftBreak :: Char -- | The character to use for the note bullet. -- Defaults to: @=@. - , cNoteBullet :: Char + , cNoteBullet :: Char -- | The character to use for marking a single-line primary label. -- Defaults to: @^@. - , cSinglePrimaryCaret :: Char + , cSinglePrimaryCaret :: Char -- | The character to use for marking a single-line secondary label. -- Defaults to: @-@. - , cSingleSecondaryCaret :: Char + , cSingleSecondaryCaret :: Char + -- | The character to use for marking a single-line add label. + -- Defaults to: @^@. + , cSingleAddCaret :: Char + -- | The character to use for marking a single-line remove label. + -- Defaults to: @-@. + , cSingleRemoveCaret :: Char -- | The character to use for marking the start of a multi-line primary label. -- Defaults to: @^@. - , cMultiPrimaryCaretStart :: Char + , cMultiPrimaryCaretStart :: Char -- | The character to use for marking the end of a multi-line primary label. -- Defaults to: @^@. - , cMultiPrimaryCaretEnd :: Char + , cMultiPrimaryCaretEnd :: Char -- | The character to use for marking the start of a multi-line secondary label. -- Defaults to: @\'@. , cMultiSecondaryCaretStart :: Char -- | The character to use for marking the end of a multi-line secondary label. -- Defaults to: @\'@. - , cMultiSecondaryCaretEnd :: Char + , cMultiSecondaryCaretEnd :: Char + -- | The character to use for marking the start of a multi-line remove label. + -- Defaults to: @~@. + , cMultiRemoveCaretStart :: Char + -- | The character to use for marking the end of a multi-line remove label. + -- Defaults to: @~@. + , cMultiRemoveCaretEnd :: Char -- | The character to use for the top-left corner of a multi-line label. -- Defaults to: @╭@ or @/@ with asciiChars. - , cMultiTopLeft :: Char + , cMultiTopLeft :: Char -- | The character to use for the top of a multi-line label. -- Defaults to: @─@ or @-@ with asciiChars. - , cMultiTop :: Char + , cMultiTop :: Char -- | The character to use for the bottom-left corner of a multi-line label. -- Defaults to: @╰@ or @\\@ with asciiChars. - , cMultiBottomLeft :: Char + , cMultiBottomLeft :: Char -- | The character to use when marking the bottom of a multi-line label. -- Defaults to: @─@ or @-@ with asciiChars. - , cMultiBottom :: Char + , cMultiBottom :: Char -- | The character to use for the left of a multi-line label. -- Defaults to: @│@ or @|@ with asciiChars. - , cMultiLeft :: Char + , cMultiLeft :: Char -- | The character to use for the left of a pointer underneath a caret. -- Defaults to: @│@ or @|@ with asciiChars. - , cPointerLeft :: Char + , cPointerLeft :: Char } deriving (Show) unicodeChars :: Chars @@ -59,10 +71,14 @@ unicodeChars = Chars , cNoteBullet = '=' , cSinglePrimaryCaret = '^' , cSingleSecondaryCaret = '-' + , cSingleAddCaret = '+' + , cSingleRemoveCaret = '~' , cMultiPrimaryCaretStart = '^' , cMultiPrimaryCaretEnd = '^' , cMultiSecondaryCaretStart = '\'' , cMultiSecondaryCaretEnd = '\'' + , cMultiRemoveCaretStart = '~' + , cMultiRemoveCaretEnd = '~' , cMultiTopLeft = '╭' , cMultiTop = '─' , cMultiBottomLeft = '╰' @@ -79,10 +95,14 @@ asciiChars = Chars , cNoteBullet = '=' , cSinglePrimaryCaret = '^' , cSingleSecondaryCaret = '-' + , cSingleAddCaret = '+' + , cSingleRemoveCaret = '~' , cMultiPrimaryCaretStart = '^' , cMultiPrimaryCaretEnd = '^' , cMultiSecondaryCaretStart = '\'' , cMultiSecondaryCaretEnd = '\'' + , cMultiRemoveCaretStart = '~' + , cMultiRemoveCaretEnd = '~' , cMultiTopLeft = ' ' , cMultiTop = '_' , cMultiBottomLeft = '|' diff --git a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs index e2a5dc6..bd370f8 100644 --- a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs +++ b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} @@ -14,19 +15,19 @@ import qualified Data.Text as T (length, split) import Control.Arrow ((&&&)) import Data.Array.Unboxed (UArray) -import Data.Bifunctor (bimap, second) +import Data.Bifunctor (bimap, first, second) import Data.Char (isSpace, ord) import Data.Char.WCWidth (wcwidth) import Data.Foldable (maximumBy) import Data.Function (on) import Data.List (dropWhileEnd, groupBy, intersperse, nub, sort, sortOn, uncons, unfoldr) -import Data.Maybe (fromJust, isJust) +import Data.Maybe (fromJust, isJust, mapMaybe) import Data.Ord (comparing) import Text.Printf (printf) -import qualified Error.Diagnose as E (Note (Hint, Note)) +import qualified Error.Diagnose as E (Note (..), Severity (..)) -import Error.Diagnose (Marker (..), Note, Position (..), Report (..), align, hsep) +import Error.Diagnose (NoteMarker (..), Position (..), Report (..), SimpleMarker (..), align, hsep) import Error.Diagnose.Layout (FileMap) import Prettyprinter (Doc, Pretty (..), annotate, brackets, colon, column, emptyDoc, fill, hardline, space, (<+>)) import Prettyprinter.Internal (Doc (..)) @@ -37,6 +38,12 @@ unicodeWidth tabSize col c@(wcwidth -> w) | c == '\t' = (col `div` tabSize + 1) * tabSize - col | otherwise = error (printf "negative width for '%c' (0x%04x)" c (ord c)) +simpleWidth :: Char -> Int +simpleWidth c@(wcwidth -> w) + | w >= 0 = w + | c == '\t' = error "simpleWidth: cannot handle tab character" + | otherwise = error (printf "negative width for '%c' (0x%04x)" c (ord c)) + data Severity = Bug | Error @@ -63,35 +70,26 @@ data Annotation deriving (Show, Eq) data MarkerStyle - = SThis - | SWhere - | SMaybe + = SAdd + | SRemove + | SPrimary + | SSecondary | SBlank deriving (Show, Eq, Ord) +data Marker msg = Marker + { markerStyle :: MarkerStyle + , markerMessage :: Maybe msg + , markerInsertion :: Maybe String + } deriving (Show) + nonBlank :: [(a, Marker msg)] -> [(a, Marker msg)] nonBlank = filter ((/= SBlank) . markerStyle . snd) -markerStyle :: Marker msg -> MarkerStyle -markerStyle (This _) = SThis -markerStyle (Where _) = SWhere -markerStyle (Maybe _) = SMaybe -markerStyle Blank = SBlank - -markerMessage :: Marker msg -> Maybe msg -markerMessage (This msg) = Just msg -markerMessage (Where msg) = Just msg -markerMessage (Maybe msg) = Just msg -markerMessage Blank = Nothing - -reportComponents :: Report msg -> (Severity, Maybe msg, msg, [(Position, Marker msg)], [Note msg]) -reportComponents (Warn code msg markers notes) = (Warning, code, msg, markers, notes) -reportComponents (Err code msg markers notes) = (Error, code, msg, markers, notes) - takeNAndOthers :: Pretty a => Int -> [a] -> Doc ann -takeNAndOthers 0 _ = error "takeNAndOthers: cannot take 0" -takeNAndOthers _ [] = error "takeNAndOthers: empty list" -takeNAndOthers n (first : rest) = pretty first <> go (pred n) rest +takeNAndOthers 0 _ = error "takeNAndOthers: cannot take 0" +takeNAndOthers _ [] = error "takeNAndOthers: empty list" +takeNAndOthers n (x0 : rest) = pretty x0 <> go (pred n) rest where go _ [] = emptyDoc go 0 [x] = ", and " <> pretty x go 0 others = ", and " <> pretty (length others) <> " other(s)" @@ -109,6 +107,9 @@ type Line = Int type Column = Int type Range a = (a, a) +mapRange :: (a -> b) -> Range a -> Range b +mapRange f = bimap f f + inRange :: Ord a => a -> Range a -> Bool x `inRange` (l, r) = l <= x && x <= r @@ -150,13 +151,57 @@ linesForMultis = nub . sort . concatMap linesForMulti 4. Associate each line with its single-line markers and multi-line markers in its group (determined in 2) 5. Render each line with the associated markers + + 6. Render notes and helps (no markers: inline; with markers: sub-report) -} +data GenReport msg = GenReport + { reportSeverity :: Severity + , reportErrorCode :: Maybe msg + , reportMessage :: msg + , reportMarkers :: [(Position, Marker msg)] + , reportNotes :: [(Severity, msg)] + , reportSubReports :: [GenReport msg] + } + +reportToGenReport :: Report msg -> GenReport msg +reportToGenReport (Report sev reportErrorCode reportMessage markers notes) = GenReport{..} + where reportSeverity = case sev of + E.Warning -> Warning + E.Error -> Error + E.Critical -> Bug + reportMarkers = map (second simpleMarkerToMarker) markers + classifyNote (noteSev, msg, m) + | null m = Left (noteSev, msg) + | otherwise = Right (noteToGenReport noteSev msg m) + noteToTriple (E.Note msg ms) = (Note, msg, ms) + noteToTriple (E.Hint msg ms) = (Help, msg, ms) + (reportNotes, reportSubReports) = partitionEither (classifyNote . noteToTriple) notes + +simpleMarkerToMarker :: SimpleMarker msg -> Marker msg +simpleMarkerToMarker (Primary msg) = Marker SPrimary (Just msg) Nothing +simpleMarkerToMarker (Secondary msg) = Marker SSecondary (Just msg) Nothing +simpleMarkerToMarker Blank = Marker SBlank Nothing Nothing + +noteToGenReport :: Severity -> msg -> [(Position, NoteMarker msg)] -> GenReport msg +noteToGenReport reportSeverity reportMessage (map (second noteMarkerToMarker) -> reportMarkers) + = GenReport{reportErrorCode = Nothing, reportNotes = [], reportSubReports = [], ..} + +noteMarkerToMarker :: NoteMarker msg -> Marker msg +noteMarkerToMarker (AddCode text msg) = Marker SAdd (Just msg) (Just text) +noteMarkerToMarker (RemoveCode msg) = Marker SRemove (Just msg) Nothing +noteMarkerToMarker (Annotate msg) = Marker SSecondary (Just msg) Nothing + report :: Pretty msg => FileMap -> Chars -> Int -> Report msg -> Doc Annotation -report fileMap chars@Chars{ cNoteBullet, cSourceBorderLeft } - tabSize (reportComponents -> (sev, code, msg, markers, notes)) +report fileMap chars tabSize = genReport fileMap chars tabSize . reportToGenReport + +genReport :: Pretty msg => FileMap -> Chars -> Int -> GenReport msg -> Doc Annotation +genReport fileMap chars@Chars{ cSourceBorderLeft } tabSize + GenReport{ reportSeverity = sev, reportErrorCode = code, reportMessage = msg + , reportMarkers = markers, reportNotes = notes, reportSubReports = subReports } = header sev code msg <> foldMap renderFile groups - <> foldMap renderNote notes + <> foldMap (renderInlineNote chars maxLnWidth) notes + <> foldMap (genReport fileMap chars tabSize) subReports where groups = sortMarkers markers maxLnWidth = length $ show $ maximum $ 0 : concatMap go markers where go (Position{ begin, end }, _) = [fst begin, snd end] @@ -181,13 +226,6 @@ report fileMap chars@Chars{ cNoteBullet, cSourceBorderLeft } where allLines = nub $ sort $ concatMap (\(Position{..}, _) -> [fst begin, fst end]) thisMarkers startPos = fst (head thisMarkers) makeBug s = leftPadding <+> annotate (Header Bug) "bug" <> annotate HeaderMessage (colon <+> s) <> hardline - renderNote nt - -- ' = : ' - = leftPadding <+> annotate NoteBullet (pretty cNoteBullet) - <+> pretty @String noteLevel <> colon <+> align (pretty noteMsg) <> hardline - where (noteLevel, noteMsg) = case nt of - E.Hint m -> ("hint", m) - E.Note m -> ("note", m) partitionEither :: (a -> Either b c) -> [a] -> ([b], [c]) partitionEither p = foldr go ([], []) @@ -325,6 +363,39 @@ filterIndex p = map snd . filter (p . fst) . indexed filterIndexed :: (a -> Bool) -> [a] -> [(Int, a)] filterIndexed p = filter (p . snd) . indexed +-- | 6. Render notes and helps (no markers: inline; with markers: sub-report) +renderInlineNote :: Pretty msg => Chars -> Int -> (Severity, msg) -> Doc Annotation +renderInlineNote Chars{ cNoteBullet } maxLnWidth (noteSev, noteMsg) + -- ' = : ' + = pad maxLnWidth "" <+> annotate NoteBullet (pretty cNoteBullet) + <+> pretty noteSev <> colon <+> align (pretty noteMsg) <> hardline + +data ExtColumn = ExtColumn + { realColumn :: {-# UNPACK #-} !Int + , extColumn :: {-# UNPACK #-} !Int + } deriving (Show, Eq, Ord) + +pattern RealColumn :: Int -> ExtColumn +pattern RealColumn n = ExtColumn{ realColumn = n, extColumn = 0 } + +nextColumn :: ExtColumn -> ExtColumn +nextColumn ExtColumn{ realColumn } = ExtColumn{ realColumn = realColumn + 1, extColumn = 0 } + +mergeAscendingOn :: Ord k => (a -> k) -> [a] -> [a] -> [a] +mergeAscendingOn key = go + where go [] ys = ys + go xs [] = xs + go (x : xs) (y : ys) = case compare (key x) (key y) of + LT -> x : go xs (y : ys) + EQ -> error "mergeAscendingOn: EQ" + GT -> y : go (x : xs) ys + +extendLast :: (a -> a) -> [a] -> [a] +extendLast _ [] = error "extendLast: empty list" +extendLast f (x0 : rest) = go x0 rest + where go x [] = [x, f x] + go x (y : xs) = x : go y xs + -- | Rendered source line, with line number and multi-line markers on the left. -- -- > 10 │ │ muffin. Halvah croissant candy canes bonbon candy. Apple pie jelly @@ -342,10 +413,10 @@ sourceLine Chars{..} tabSize lnWidth maxMultiCount sev MarkedLine{ isRealSource, lineNumber = ln, lineText = (trimEnd -> text) , singleMarkers = singles, multiMarkers = multis, nextMarkers } -- > 10 │ │ muffin. Halvah croissant candy canes bonbon candy. Apple pie jelly - = headLeader <+> attachColour text <> hardline + = headLeader <+> attachColour decoratedText <> hardline -- > │ │ ^^^^^^ -------^^^^^^^^^-------^^^^^------- ^^^^^ trailing label message <> (if null singles then emptyDoc else - tailLeader <+> drawMarkers text <> trailingMsgRendered <> hardline) + tailLeader <+> renderedMarkers <> trailingMsgRendered <> hardline) <> (if nDanglingMsgs == 0 then emptyDoc else -- > │ │ │ │ allPointerLines <> hardline @@ -370,35 +441,46 @@ sourceLine Chars{..} tabSize lnWidth maxMultiCount sev | otherwise = space where ann = annotate (MarkerTint sev st) leadingSpaces = length (takeWhile isSpace text) + -- handle text insertion + decoratedText + = mergeAscendingOn fst insertions + $ zip (map RealColumn [1..]) + $ zipWith handleTab [0..] text + insertions = concat (mapMaybe go singles) + where go ((l, _), m) = attachColumn l <$> markerInsertion m + attachColumn l = zip (map (ExtColumn l) [1..]) . zipWith handleTab [l - 1..] -- attach colour for the source code text attachColour = foldMap (renderSegment . (fst . head &&& concatMap snd)) . groupBy ((==) `on` fst) - . zip (map styleOf [1..]) - . zipWith handleTab [0..] + . map (first styleOf) handleTab k '\t' = replicate (unicodeWidth tabSize k '\t') ' ' handleTab _ c = [c] renderSegment (st, s) = annotate (SourceTint sev st) (pretty s) maxStyle = minimum . (SBlank :) . map (markerStyle . snd) - styleOf col = - let s = filter (inRange col . fst) singles - m = filter (inRange (ln, col) . fst) multis - in maxStyle s `min` maxStyle m + styleOf = uncurry min . (styleOfSingle &&& styleOfMulti) + styleOfMulti col = maxStyle $ filter (inRange (ln, col) . mapRange (second RealColumn) . fst) multis + styleOfSingle col = maxStyle sm + where sm = filter (\(rng, markerStyle -> m) -> inRange col (liftRange m rng)) singles + liftRange SAdd (l, r) = (ExtColumn l 1, ExtColumn l (r - l + 1)) + liftRange _ rng = mapRange RealColumn rng -- handle single-line markers - drawMarkers + renderedMarkers = foldMap renderMarker - . dropWhileEnd ((== SBlank) . fst) - . map (fst . head &&& sum . map snd) - . groupBy ((==) `on` fst) - . zip (map styleOfSingle [1..]) - . (++ [1]) - . zipWith (unicodeWidth tabSize) [0..] + $ dropWhileEnd ((== SBlank) . fst) + $ map (fst . head &&& sum . map snd) + $ groupBy ((==) `on` fst) + $ map (first styleOfSingle) + $ extendLast (bimap nextColumn (const 1)) + $ map (second (sum . map simpleWidth)) decoratedText renderMarker (st, k) = ann (pretty (replicate k c)) - where c | SThis <- st = cSinglePrimaryCaret - | SBlank <- st = ' ' - | otherwise = cSingleSecondaryCaret + where c = case st of + SPrimary -> cSinglePrimaryCaret + SSecondary -> cSingleSecondaryCaret + SAdd -> cSingleAddCaret + SRemove -> cSingleRemoveCaret + SBlank -> ' ' ann = if st == SBlank then id else annotate (MarkerTint sev st) - styleOfSingle col = maxStyle (filter (inRange col . fst) singles) trailingMsgRendered = maybe emptyDoc go trailingMsg where go (_, markerStyle &&& markerMessage -> (st, ~(Just msg))) = space <> align' st (pretty msg) @@ -452,8 +534,12 @@ sourceLine Chars{..} tabSize lnWidth maxMultiCount sev outerSt = markerStyle outer annDoc = annotate (MarkerTint sev outerSt) ann m = annotate (MarkerTint sev m) . pretty - st = if markerStyle outer == SThis then cMultiPrimaryCaretStart else cMultiSecondaryCaretStart - ed = if markerStyle outer == SThis then cMultiPrimaryCaretEnd else cMultiSecondaryCaretEnd + (st, ed) = case markerStyle outer of + SPrimary -> (cMultiPrimaryCaretStart, cMultiPrimaryCaretEnd) + SSecondary -> (cMultiSecondaryCaretStart, cMultiSecondaryCaretEnd) + SAdd -> error "marker Add should not be multiline" + SRemove -> (cMultiRemoveCaretStart, cMultiRemoveCaretEnd) + SBlank -> error "impossible: unexpected Blank marker" multiMarkerLeft isMain (k', (((lnS', _), (lnE', _)), markerStyle -> inner)) | through, k' < k = ann inner cMultiLeft <> space | through = ann inner cMultiLeft <> pBar From 7870564798181e0fb78627bdbf914a94db131106 Mon Sep 17 00:00:00 2001 From: Ruifeng Xie Date: Thu, 20 Oct 2022 22:12:08 +0800 Subject: [PATCH 10/10] codespan-reporting: fix type errors after rebase --- .../Diagnose/Layout/CodeSpanReporting.hs | 41 ++----- .../Layout/CodeSpanReporting/Render.hs | 115 ++++++++++++------ 2 files changed, 90 insertions(+), 66 deletions(-) diff --git a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs index 830edff..1680120 100644 --- a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs +++ b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting.hs @@ -1,12 +1,15 @@ -module Error.Diagnose.Layout.CodeSpanReporting (codespanReportingLayout, defaultStyle) where +{-# LANGUAGE FlexibleContexts #-} +module Error.Diagnose.Layout.CodeSpanReporting + ( codespanReportingLayout + , codespanReportingStyle + ) where -import Error.Diagnose.Diagnostic (filesOf, reportsOf) -import Error.Diagnose.Layout (Layout) -import Error.Diagnose.Style (Style, reAnnotate) +import Error.Diagnose.Diagnostic (Diagnostic, filesOf, reportsOf) -import Error.Diagnose (Color (..), bold, color, colorDull) +import Error.Diagnose (AnsiStyle, IsAnnotation (mkColor)) import qualified Error.Diagnose.Layout.CodeSpanReporting.Config as R import qualified Error.Diagnose.Layout.CodeSpanReporting.Render as R +import Prettyprinter (Doc, Pretty, reAnnotate) -- | Pretty prints a 'Diagnostic' into a 'Doc'ument that can be output using 'hPutDoc'. -- @@ -19,33 +22,11 @@ import qualified Error.Diagnose.Layout.CodeSpanReporting.Render as R -- -- >>> let myCustomStyle :: Style = _ -- >>> let doc = myCustomStyle (prettyDiagnostic withUnicode tabSize diagnostic) -codespanReportingLayout :: Layout R.Annotation msg +codespanReportingLayout :: Pretty msg => Bool -> Int -> Diagnostic msg -> Doc R.Annotation codespanReportingLayout withUnicode tabSize diag = foldMap (R.report (filesOf diag) chars tabSize) (reportsOf diag) - -- fold . intersperse hardline $ prettyReport (filesOf diag) withUnicode tabSize <$> reportsOf diag where chars = if withUnicode then R.unicodeChars else R.asciiChars {-# INLINE codespanReportingLayout #-} -defaultStyle :: Style R.Annotation -defaultStyle = reAnnotate \case - R.Header R.Bug -> bold <> color Red - R.Header R.Error -> bold <> color Red - R.Header R.Warning -> bold <> color Yellow - R.Header R.Note -> bold <> color Green - R.Header R.Help -> bold <> color Cyan - R.HeaderMessage -> bold <> color White - R.SourceBorder -> colorDull Cyan -- Blue - R.NoteBullet -> colorDull Cyan -- Blue - R.LineNumber -> colorDull Cyan -- Blue - R.SourceTint sev sty -> marker sev sty True - R.MarkerTint sev sty -> marker sev sty False - where marker R.Bug R.SPrimary _ = colorDull Red - marker R.Error R.SPrimary _ = colorDull Red - marker R.Warning R.SPrimary _ = colorDull Yellow - marker R.Note R.SPrimary _ = colorDull Green - marker R.Help R.SPrimary _ = colorDull Cyan - marker _ R.SBlank _ = mempty - marker _ R.SAdd _ = color Green - marker _ R.SRemove _ = color Red - marker _ R.SSecondary True = colorDull White - marker _ R.SSecondary False = colorDull Cyan -- Blue +codespanReportingStyle :: Doc R.Annotation -> Doc AnsiStyle +codespanReportingStyle = reAnnotate mkColor diff --git a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs index bd370f8..2eee359 100644 --- a/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs +++ b/diagnose-codespan-reporting/src/Error/Diagnose/Layout/CodeSpanReporting/Render.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} @@ -16,21 +18,22 @@ import qualified Data.Text as T (length, split) import Control.Arrow ((&&&)) import Data.Array.Unboxed (UArray) import Data.Bifunctor (bimap, first, second) -import Data.Char (isSpace, ord) +import Data.Char (GeneralCategory (Control), generalCategory, isSpace, ord) import Data.Char.WCWidth (wcwidth) import Data.Foldable (maximumBy) import Data.Function (on) import Data.List (dropWhileEnd, groupBy, intersperse, nub, sort, sortOn, uncons, unfoldr) -import Data.Maybe (fromJust, isJust, mapMaybe) +import Data.Maybe (fromJust, isJust, isNothing, mapMaybe) import Data.Ord (comparing) import Text.Printf (printf) -import qualified Error.Diagnose as E (Note (..), Severity (..)) +import qualified Error.Diagnose as E (Marker (..), Note (..), Severity (..)) -import Error.Diagnose (NoteMarker (..), Position (..), Report (..), SimpleMarker (..), align, hsep) +import Error.Diagnose (IsAnnotation (mkColor), MarkerKind (..), Report (..), SourceRange (..), align, hsep) import Error.Diagnose.Layout (FileMap) import Prettyprinter (Doc, Pretty (..), annotate, brackets, colon, column, emptyDoc, fill, hardline, space, (<+>)) import Prettyprinter.Internal (Doc (..)) +import Prettyprinter.Render.Terminal (Color (..), bold, color, colorDull) unicodeWidth :: Int -> Int -> Char -> Int unicodeWidth tabSize col c@(wcwidth -> w) @@ -69,6 +72,30 @@ data Annotation | MarkerTint Severity MarkerStyle deriving (Show, Eq) +instance IsAnnotation Annotation where + mkColor = \case + Header Bug -> bold <> color Red + Header Error -> bold <> color Red + Header Warning -> bold <> color Yellow + Header Note -> bold <> color Green + Header Help -> bold <> color Cyan + HeaderMessage -> bold <> color White + SourceBorder -> colorDull Cyan -- Blue + NoteBullet -> colorDull Cyan -- Blue + LineNumber -> colorDull Cyan -- Blue + SourceTint sev sty -> marker sev sty True + MarkerTint sev sty -> marker sev sty False + where marker Bug SPrimary _ = colorDull Red + marker Error SPrimary _ = colorDull Red + marker Warning SPrimary _ = colorDull Yellow + marker Note SPrimary _ = colorDull Green + marker Help SPrimary _ = colorDull Cyan + marker _ SBlank _ = mempty + marker _ SAdd _ = color Green + marker _ SRemove _ = color Red + marker _ SSecondary True = colorDull White + marker _ SSecondary False = colorDull Cyan -- Blue + data MarkerStyle = SAdd | SRemove @@ -159,7 +186,7 @@ data GenReport msg = GenReport { reportSeverity :: Severity , reportErrorCode :: Maybe msg , reportMessage :: msg - , reportMarkers :: [(Position, Marker msg)] + , reportMarkers :: [(SourceRange, Marker msg)] , reportNotes :: [(Severity, msg)] , reportSubReports :: [GenReport msg] } @@ -170,27 +197,28 @@ reportToGenReport (Report sev reportErrorCode reportMessage markers notes) = Gen E.Warning -> Warning E.Error -> Error E.Critical -> Bug - reportMarkers = map (second simpleMarkerToMarker) markers - classifyNote (noteSev, msg, m) - | null m = Left (noteSev, msg) - | otherwise = Right (noteToGenReport noteSev msg m) + reportMarkers = map mainMarkerToMarker markers + classifyNote (noteSev, msg, mm) + | Just m <- mm = Right (noteToGenReport noteSev msg m) + | otherwise = Left (noteSev, msg) noteToTriple (E.Note msg ms) = (Note, msg, ms) noteToTriple (E.Hint msg ms) = (Help, msg, ms) (reportNotes, reportSubReports) = partitionEither (classifyNote . noteToTriple) notes -simpleMarkerToMarker :: SimpleMarker msg -> Marker msg -simpleMarkerToMarker (Primary msg) = Marker SPrimary (Just msg) Nothing -simpleMarkerToMarker (Secondary msg) = Marker SSecondary (Just msg) Nothing -simpleMarkerToMarker Blank = Marker SBlank Nothing Nothing +mainMarkerToMarker :: E.Marker msg 'MainMarker -> (SourceRange, Marker msg) +mainMarkerToMarker (E.Primary range msg) = (range, Marker SPrimary msg Nothing) +mainMarkerToMarker (E.Secondary range msg) = (range, Marker SSecondary msg Nothing) +mainMarkerToMarker (E.Blank range) = (range, Marker SBlank Nothing Nothing) -noteToGenReport :: Severity -> msg -> [(Position, NoteMarker msg)] -> GenReport msg -noteToGenReport reportSeverity reportMessage (map (second noteMarkerToMarker) -> reportMarkers) +noteToGenReport :: Severity -> msg -> E.Marker msg 'NoteMarker -> GenReport msg +noteToGenReport reportSeverity reportMessage (pure . noteMarkerToMarker -> reportMarkers) = GenReport{reportErrorCode = Nothing, reportNotes = [], reportSubReports = [], ..} -noteMarkerToMarker :: NoteMarker msg -> Marker msg -noteMarkerToMarker (AddCode text msg) = Marker SAdd (Just msg) (Just text) -noteMarkerToMarker (RemoveCode msg) = Marker SRemove (Just msg) Nothing -noteMarkerToMarker (Annotate msg) = Marker SSecondary (Just msg) Nothing +noteMarkerToMarker :: E.Marker msg 'NoteMarker -> (SourceRange, Marker msg) +noteMarkerToMarker (E.AddCode begin@(l, c) file len text) + = (Range{ file, begin, end = (l, c + len - 1) }, Marker SAdd Nothing (Just text)) +noteMarkerToMarker (E.RemoveCode range) = (range, Marker SRemove Nothing Nothing) +noteMarkerToMarker (E.Annotate range msg) = (range, Marker SSecondary msg Nothing) report :: Pretty msg => FileMap -> Chars -> Int -> Report msg -> Doc Annotation report fileMap chars tabSize = genReport fileMap chars tabSize . reportToGenReport @@ -204,14 +232,14 @@ genReport fileMap chars@Chars{ cSourceBorderLeft } tabSize <> foldMap (genReport fileMap chars tabSize) subReports where groups = sortMarkers markers maxLnWidth = length $ show $ maximum $ 0 : concatMap go markers - where go (Position{ begin, end }, _) = [fst begin, snd end] + where go (Range{ begin, end }, _) = [fst begin, snd end] leftPadding = pad maxLnWidth "" trailingLeftBorder = leftPadding <+> annotate SourceBorder (pretty cSourceBorderLeft) <> hardline sortMarkers = map (file . fst . head &&& id) . groupBy ((==) `on` file . fst) . sortOn (posToTriple . fst) - posToTriple Position{ begin, end, file } = (file, begin, end) + posToTriple Range{ begin, end, file } = (file, begin, end) renderFile (fileName, thisMarkers) | Just fileLines <- fileMap H.!? fileName , let (singles, multis) = classifyAndGroupMarkers fileLines thisMarkers @@ -223,7 +251,7 @@ genReport fileMap chars@Chars{ cSourceBorderLeft } tabSize then snippetStart chars maxLnWidth startPos <> foldMap go markedLines <> trailingLeftBorder else makeBug ("line " <> takeNAndOthers 2 missingLines <> " of file '" <> pretty fileName <> "' not available") | otherwise = makeBug ("content of file '" <> pretty fileName <> "' not available") - where allLines = nub $ sort $ concatMap (\(Position{..}, _) -> [fst begin, fst end]) thisMarkers + where allLines = nub $ sort $ concatMap (\(Range{..}, _) -> [fst begin, fst end]) thisMarkers startPos = fst (head thisMarkers) makeBug s = leftPadding <+> annotate (Header Bug) "bug" <> annotate HeaderMessage (colon <+> s) <> hardline @@ -233,12 +261,12 @@ partitionEither p = foldr go ([], []) go (p -> Right c) ~(bs, cs) = (bs, c : cs) -- | 1. Classify single-line and multi-line markers -classifyMarkers :: [(Position, Marker msg)] -> ([(Line, SingleMarker msg)], [MultiMarker msg]) +classifyMarkers :: [(SourceRange, Marker msg)] -> ([(Line, SingleMarker msg)], [MultiMarker msg]) classifyMarkers = partitionEither \(pos, marker) -> - let Position{ begin = begin@(lnS, colS), end = end@(lnE, colE) } = pos + let Range{ begin = begin@(lnS, colS), end = end@(lnE, colE) } = pos in if lnS == lnE then Left (lnS, ((colS, colE), marker)) else Right ((begin, end), marker) -classifyAndGroupMarkers :: A.Array Int String -> [(Position, Marker msg)] -> ([(Line, [SingleMarker msg])], [MultiGroup msg]) +classifyAndGroupMarkers :: A.Array Int String -> [(SourceRange, Marker msg)] -> ([(Line, [SingleMarker msg])], [MultiGroup msg]) classifyAndGroupMarkers fileLines = bimap groupSingles (groupMultis fileLines) . classifyMarkers -- | 2. Group multi-line markers into disjoint groups @@ -336,8 +364,8 @@ header sev code msg -- message: ': unexpected type in `+` application' <> annotate HeaderMessage (colon <+> align (pretty msg)) <> hardline -snippetStart :: Chars -> Int -> Position -> Doc Annotation -snippetStart Chars{ cSnippetStart } k Position{ file, begin = (ln, col) } +snippetStart :: Chars -> Int -> SourceRange -> Doc Annotation +snippetStart Chars{ cSnippetStart } k Range{ file, begin = (ln, col) } -- rendered as: ' ┌─ test:2:9' = pad k "" <+> annotate SourceBorder (pretty cSnippetStart) <+> pretty file <> colon <> pretty ln <> colon <> pretty col @@ -370,16 +398,25 @@ renderInlineNote Chars{ cNoteBullet } maxLnWidth (noteSev, noteMsg) = pad maxLnWidth "" <+> annotate NoteBullet (pretty cNoteBullet) <+> pretty noteSev <> colon <+> align (pretty noteMsg) <> hardline -data ExtColumn = ExtColumn +newtype ExtInt = ExtInt Int deriving (Show, Eq) +instance Ord ExtInt where + compare (ExtInt 0) (ExtInt _) = GT + compare (ExtInt _) (ExtInt 0) = LT + compare (ExtInt x) (ExtInt y) = compare x y + +data ExtColumn = MaybeExtColumn { realColumn :: {-# UNPACK #-} !Int - , extColumn :: {-# UNPACK #-} !Int + , extColumn :: {-# UNPACK #-} !ExtInt } deriving (Show, Eq, Ord) pattern RealColumn :: Int -> ExtColumn -pattern RealColumn n = ExtColumn{ realColumn = n, extColumn = 0 } +pattern RealColumn n = MaybeExtColumn{ realColumn = n, extColumn = ExtInt 0 } + +pattern ExtColumn :: Int -> Int -> ExtColumn +pattern ExtColumn l c = MaybeExtColumn{ realColumn = l, extColumn = ExtInt c } nextColumn :: ExtColumn -> ExtColumn -nextColumn ExtColumn{ realColumn } = ExtColumn{ realColumn = realColumn + 1, extColumn = 0 } +nextColumn MaybeExtColumn{ realColumn } = MaybeExtColumn{ realColumn = realColumn + 1, extColumn = ExtInt 0 } mergeAscendingOn :: Ord k => (a -> k) -> [a] -> [a] -> [a] mergeAscendingOn key = go @@ -417,7 +454,7 @@ sourceLine Chars{..} tabSize lnWidth maxMultiCount sev -- > │ │ ^^^^^^ -------^^^^^^^^^-------^^^^^------- ^^^^^ trailing label message <> (if null singles then emptyDoc else tailLeader <+> renderedMarkers <> trailingMsgRendered <> hardline) - <> (if nDanglingMsgs == 0 then emptyDoc else + <> (if not anyDanglingMsg then emptyDoc else -- > │ │ │ │ allPointerLines <> hardline -- > │ │ │ croissant is mentioned here @@ -447,7 +484,8 @@ sourceLine Chars{..} tabSize lnWidth maxMultiCount sev $ zip (map RealColumn [1..]) $ zipWith handleTab [0..] text insertions = concat (mapMaybe go singles) - where go ((l, _), m) = attachColumn l <$> markerInsertion m + where go ((l, _), m) = attachColumn l . map replaceNewline <$> markerInsertion m + replaceNewline c = if generalCategory c == Control then ' ' else c attachColumn l = zip (map (ExtColumn l) [1..]) . zipWith handleTab [l - 1..] -- attach colour for the source code text attachColour @@ -508,15 +546,19 @@ sourceLine Chars{..} tabSize lnWidth maxMultiCount sev = filter ((/= SBlank) . markerStyle . snd) $ filterIndex ((/= fmap fst trailingMsg) . Just) singles nDanglingMsgs = length danglingMsgs + anyDanglingMsg = any (isJust . markerMessage . snd) danglingMsgs renderDanglingUntil k = foldl go emptyDoc (take k danglingMsgs) - where go cur ((colS, _), markerStyle -> st) - = fill (widthTable A.! colS) cur <> annotate (MarkerTint sev st) (pretty cPointerLeft) + where go cur ((colS, _), m@(markerStyle -> st)) + | isNothing (markerMessage m) = emptyDoc + | otherwise = fill (widthTable A.! colS) cur + <> annotate (MarkerTint sev st) (pretty cPointerLeft) allPointerLines = tailLeader <+> renderDanglingUntil nDanglingMsgs drawDanglingMsgs k | k < 0 = emptyDoc + | withoutMessage = drawDanglingMsgs (pred k) | otherwise = leader <> pMsg <> hardline <> drawDanglingMsgs (pred k) where ((colS, _), marker) = danglingMsgs !! k - ~(Just msg) = markerMessage marker + (withoutMessage, msg) = maybe (True, undefined) (False, ) (markerMessage marker) st = markerStyle marker pMsg = replaceLinesWith (hardline <> leader) (annotate (MarkerTint sev st)) (pretty msg) leader = tailLeader <+> fill (widthTable A.! colS) (renderDanglingUntil k) @@ -533,6 +575,7 @@ sourceLine Chars{..} tabSize lnWidth maxMultiCount sev cont = hardline <> multiLeader False <> pretty (replicate (succ colE) ' ') outerSt = markerStyle outer annDoc = annotate (MarkerTint sev outerSt) + ann :: Pretty a => MarkerStyle -> a -> Doc Annotation ann m = annotate (MarkerTint sev m) . pretty (st, ed) = case markerStyle outer of SPrimary -> (cMultiPrimaryCaretStart, cMultiPrimaryCaretEnd)