mirror of
https://github.com/Mesabloo/diagnose.git
synced 2024-08-17 07:10:35 +03:00
Correct behaviour of Nesting
This commit is contained in:
parent
604f083fa1
commit
3a99b70403
@ -50,7 +50,7 @@ import Data.String (IsString (fromString))
|
||||
import qualified Data.Text as Text
|
||||
import Error.Diagnose.Position
|
||||
import Error.Diagnose.Style (Annotation (..))
|
||||
import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>), reAnnotate)
|
||||
import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>), reAnnotate, SimpleDocStream (..), layoutCompact)
|
||||
import Prettyprinter.Internal (Doc (..), textSpaces)
|
||||
import Data.Bool (bool)
|
||||
|
||||
@ -493,7 +493,7 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu
|
||||
let colorOfFirstMultilineMarker = markerColor isError . snd <$> List.safeHead multiline
|
||||
-- take the color of the last multiline marker in case we need to add additional bars
|
||||
|
||||
prefix = hardline <+> dotPrefix leftLen withUnicode <> space
|
||||
prefix = space <> dotPrefix leftLen withUnicode <> space
|
||||
|
||||
prefixWithBar color = prefix <> maybe id annotate color (unicode "| " "│ " withUnicode)
|
||||
|
||||
@ -504,12 +504,12 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu
|
||||
then unicode "`- " "╰╸ " withUnicode
|
||||
else unicode "|- " "├╸ " withUnicode
|
||||
)
|
||||
<> replaceLinesWith (if isLast then prefix <> " " else prefixWithBar (Just $ markerColor isError marker) <> space) (annotated $ markerMessage marker)
|
||||
<> replaceLinesWith (if isLast then prefix <> " " else prefixWithBar (Just $ markerColor isError marker) <> space) 0 (annotated $ markerMessage marker)
|
||||
|
||||
showMultilineMarkerMessages [] = []
|
||||
showMultilineMarkerMessages [m] = [showMultilineMarkerMessage m True]
|
||||
showMultilineMarkerMessages (m : ms) = showMultilineMarkerMessage m False : showMultilineMarkerMessages ms
|
||||
in prefixWithBar colorOfFirstMultilineMarker <> prefix <> fold (List.intersperse prefix $ showMultilineMarkerMessages multiline)
|
||||
in hardline <> prefixWithBar colorOfFirstMultilineMarker <> hardline <> prefix <> fold (List.intersperse (hardline <> prefix) $ showMultilineMarkerMessages multiline)
|
||||
|
||||
-- |
|
||||
getLine_ ::
|
||||
@ -619,7 +619,7 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn
|
||||
Nothing -> 0
|
||||
Just col -> widthsBetween bc col
|
||||
|
||||
currentPipe = unicode (bool "`" "|" hasSuccessor) (bool "╰" "├" hasSuccessor) withUnicode
|
||||
currentPipe = unicode (bool "`" "|" hasSuccessor) (bool "╰" "├" hasSuccessor) withUnicode
|
||||
|
||||
lineChar = unicode '-' '─' withUnicode
|
||||
pointChar = unicode "-" "╸" withUnicode
|
||||
@ -633,31 +633,42 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn
|
||||
|
||||
lineStart pipesBeforeRendered
|
||||
<> annotate (markerColor isError msg) (currentPipe <> pretty (replicate lineLen lineChar) <> pointChar)
|
||||
<+> annotate (markerColor isError msg) (replaceLinesWith (hardline <+> lineStart pipesBeforeMessageRendered <+> if List.null pipesBeforeMessageStart then " " else " ") $ annotated $ markerMessage msg)
|
||||
<+> annotate (markerColor isError msg) (replaceLinesWith (space <> lineStart pipesBeforeMessageRendered <+> if List.null pipesBeforeMessageStart then " " else " ") 0 $ annotated $ markerMessage msg)
|
||||
in hardline <+> prefix <> showMessages specialPrefix pipes lineLen
|
||||
|
||||
-- WARN: uses the internal of the library
|
||||
--
|
||||
-- DO NOT use a wildcard here, in case the internal API exposes one more constructor
|
||||
|
||||
-- |
|
||||
replaceLinesWith :: Doc ann -> Doc ann -> Doc ann
|
||||
replaceLinesWith repl Line = repl
|
||||
replaceLinesWith _ Fail = Fail
|
||||
replaceLinesWith _ Empty = Empty
|
||||
replaceLinesWith _ (Char c) = Char c
|
||||
replaceLinesWith repl (Text _ s) =
|
||||
let lines = Text.split (== '\n') s <&> \txt -> Text (Text.length txt) txt
|
||||
in mconcat (List.intersperse repl lines)
|
||||
replaceLinesWith repl (FlatAlt f d) = FlatAlt (replaceLinesWith repl f) (replaceLinesWith repl d)
|
||||
replaceLinesWith repl (Cat c d) = Cat (replaceLinesWith repl c) (replaceLinesWith repl d)
|
||||
-- We need to push the nesting past our line prefix
|
||||
replaceLinesWith repl (Nest n d) = replaceLinesWith (repl <> pretty (textSpaces n)) d
|
||||
replaceLinesWith repl (Union c d) = Union (replaceLinesWith repl c) (replaceLinesWith repl d)
|
||||
replaceLinesWith repl (Column f) = Column (replaceLinesWith repl . f)
|
||||
replaceLinesWith repl (Nesting f) = Nesting (replaceLinesWith repl . f)
|
||||
replaceLinesWith repl (Annotated ann doc) = Annotated ann (replaceLinesWith repl doc)
|
||||
replaceLinesWith repl (WithPageWidth f) = WithPageWidth (replaceLinesWith repl . f)
|
||||
replaceLinesWith :: Doc ann -> Int -> Doc ann -> Doc ann
|
||||
replaceLinesWith repl = go
|
||||
where
|
||||
replWidth = sdsWidth . layoutCompact $ repl
|
||||
sdsWidth = \case
|
||||
SFail -> 0
|
||||
SEmpty -> 0
|
||||
SChar _ sds -> 1 + sdsWidth sds
|
||||
SText l _ sds -> l + sdsWidth sds
|
||||
SLine _ _ -> error "replaceLinesWith was given a prefix with a line break"
|
||||
SAnnPush _ sds -> sdsWidth sds
|
||||
SAnnPop sds -> sdsWidth sds
|
||||
replWithNesting n = hardline <> repl <> pretty (textSpaces n)
|
||||
go n = \case
|
||||
Line -> replWithNesting n
|
||||
Fail -> Fail
|
||||
Empty -> Empty
|
||||
Char c -> Char c
|
||||
Text l txt -> Text l txt
|
||||
FlatAlt f d -> FlatAlt (go n f) (go n d)
|
||||
Cat c d -> Cat (go n c) (go n d)
|
||||
Nest n' d -> go (n + n') d
|
||||
Union c d -> Union (go n c) (go n d)
|
||||
Column f -> Column (go n . f)
|
||||
-- In this case we add both our fake nesting level (from the 'Nest'
|
||||
-- constructors we've eliminated) and the nesting level from the line
|
||||
-- prefixes
|
||||
Nesting f -> Nesting (go n . f . (+ replWidth) . (+ n))
|
||||
Annotated ann doc -> Annotated ann (go n doc)
|
||||
WithPageWidth f -> WithPageWidth (go n . f)
|
||||
|
||||
-- | Extracts the color of a marker as a 'Doc' coloring function.
|
||||
markerColor ::
|
||||
@ -690,8 +701,8 @@ prettyAllHints (h : hs) leftLen withUnicode =
|
||||
A hint is composed of:
|
||||
(1) : Hint: <hint message>
|
||||
-}
|
||||
let prefix = hardline <+> pipePrefix leftLen withUnicode
|
||||
in prefix <+> annotate HintColor (notePrefix h <+> replaceLinesWith (prefix <+> " ") (annotated $ noteMessage h))
|
||||
let prefix = space <> pipePrefix leftLen withUnicode
|
||||
in hardline <> prefix <+> annotate HintColor (notePrefix h <+> replaceLinesWith prefix 7 (annotated $ noteMessage h))
|
||||
<> prettyAllHints hs leftLen withUnicode
|
||||
where
|
||||
notePrefix (Note _) = "Note:"
|
||||
|
@ -25,7 +25,8 @@ import Error.Diagnose
|
||||
TabSize (..),
|
||||
)
|
||||
import System.IO (hPutStrLn)
|
||||
import Prettyprinter (Doc, annotate, pretty, hsep, indent, vsep, nest)
|
||||
import Prettyprinter (Doc, annotate, pretty, hsep, indent, vsep, nest, (<+>), align, list)
|
||||
import Prettyprinter.Util (reflow)
|
||||
import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), color, bold, italicized, underlined)
|
||||
import Data.Traversable (mapAccumL)
|
||||
import Data.Functor.Compose (Compose(..))
|
||||
@ -162,7 +163,7 @@ nestingReport =
|
||||
(nest 4 $ vsep ["Nest...", "foo", "bar", "baz"])
|
||||
[ (Position (1, 15) (1, 16) "test.zc", Maybe a)
|
||||
]
|
||||
[Note b]
|
||||
[Note b, Hint c]
|
||||
where
|
||||
a =
|
||||
nest 3 $
|
||||
@ -172,12 +173,29 @@ nestingReport =
|
||||
, "'My favourite day,' said Pooh."
|
||||
]
|
||||
b =
|
||||
foldr1 (\p q -> nest 2 (vsep [p, q]))
|
||||
[ "It's a very funny thought that, if Bears were Bees,"
|
||||
, "They'd build their nests at the bottom of trees."
|
||||
, "And that being so (if the Bees were Bears),"
|
||||
, "We shouldn't have to climb up all these stairs."
|
||||
]
|
||||
foldr1
|
||||
(\p q -> nest 2 (vsep [p, q]))
|
||||
[ "It's a very funny thought that, if Bears were Bees,"
|
||||
, "They'd build their nests at the bottom of trees."
|
||||
, "And that being so (if the Bees were Bears),"
|
||||
, "We shouldn't have to climb up all these stairs."
|
||||
]
|
||||
c =
|
||||
"The elements:"
|
||||
<+> align
|
||||
( list
|
||||
[ "antimony"
|
||||
, "arsenic"
|
||||
, "aluminum"
|
||||
, "selenium"
|
||||
, "hydrogen"
|
||||
, "oxygen"
|
||||
, "nitrogen"
|
||||
, "rhenium"
|
||||
, align $ reflow "And there may be many others, but they haven't been discovered"
|
||||
]
|
||||
)
|
||||
|
||||
|
||||
errorNoMarkersNoHints :: Report String
|
||||
errorNoMarkersNoHints =
|
||||
|
Loading…
Reference in New Issue
Block a user