Mesabloo/diagnose
1
1
Fork 0
mirror of https://github.com/Mesabloo/diagnose.git synced 2024-11-25 23:36:30 +03:00
Code Issues Projects Releases Wiki Activity

Make interface a little more typesafe with WithUnicode and TabSize

Browse Source
This commit is contained in:
Ellie Hermaszewska 2023-05-16 12:25:10 +08:00
parent 7634d15502
commit 1578e3e388
No known key found for this signature in database
8 changed files with 80 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Error/Diagnose/Diagnostic.hs
View File

@ -29,5 +29,7 @@ import Error.Diagnose.Diagnostic.Internal as Export
printDiagnostic, printDiagnostic,
printDiagnostic', printDiagnostic',
warningsToErrors, warningsToErrors,
WithUnicode(..),
TabSize(..),
) )
import System.IO as Export (stderr, stdout) import System.IO as Export (stderr, stdout)

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

@ -16,7 +16,7 @@
-- It is also highly undocumented. -- It is also highly undocumented.
-- --
-- Please limit yourself to the "Error.Diagnose.Diagnostic" module, which exports some of the useful functions defined here. -- Please limit yourself to the "Error.Diagnose.Diagnostic" module, which exports some of the useful functions defined here.
module Error.Diagnose.Diagnostic.Internal (module Error.Diagnose.Diagnostic.Internal, def) where module Error.Diagnose.Diagnostic.Internal (module Error.Diagnose.Diagnostic.Internal, def, WithUnicode(..), TabSize(..)) where
import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Class (MonadIO, liftIO)
#ifdef USE_AESON #ifdef USE_AESON
@ -32,7 +32,7 @@ import Data.Foldable (fold, toList)
import qualified Data.HashMap.Lazy as HashMap import qualified Data.HashMap.Lazy as HashMap
import Data.List (intersperse) import Data.List (intersperse)
import Error.Diagnose.Report (Report) import Error.Diagnose.Report (Report)
import Error.Diagnose.Report.Internal (FileMap, errorToWarning, prettyReport, warningToError) import Error.Diagnose.Report.Internal (FileMap, errorToWarning, prettyReport, warningToError, WithUnicode(..), TabSize(..))
import Error.Diagnose.Style (Annotation, Style) import Error.Diagnose.Style (Annotation, Style)
import Prettyprinter (Doc, Pretty, hardline, pretty, defaultLayoutOptions, reAnnotateS, layoutPretty) import Prettyprinter (Doc, Pretty, hardline, pretty, defaultLayoutOptions, reAnnotateS, layoutPretty)
import Prettyprinter.Render.Terminal (renderIO) import Prettyprinter.Render.Terminal (renderIO)
@ -102,9 +102,9 @@ errorsToWarnings (Diagnostic reports files) = Diagnostic (errorToWarning <$> rep
prettyDiagnostic :: prettyDiagnostic ::
Pretty msg => Pretty msg =>
-- | Should we use unicode when printing paths? -- | Should we use unicode when printing paths?
Bool -> WithUnicode ->
-- | The number of spaces each TAB character will span. -- | The number of spaces each TAB character will span.
Int -> TabSize ->
-- | The diagnostic to print. -- | The diagnostic to print.
Diagnostic msg -> Diagnostic msg ->
Doc (Annotation ann) Doc (Annotation ann)
@ -117,9 +117,9 @@ prettyDiagnostic withUnicode tabSize =
-- annotations are retained in 'OtherStyle' -- annotations are retained in 'OtherStyle'
prettyDiagnostic' :: prettyDiagnostic' ::
-- | Should we use unicode when printing paths? -- | Should we use unicode when printing paths?
Bool -> WithUnicode ->
-- | The number of spaces each TAB character will span. -- | The number of spaces each TAB character will span.
Int -> TabSize ->
-- | The diagnostic to print. -- | The diagnostic to print.
Diagnostic (Doc ann) -> Diagnostic (Doc ann) ->
Doc (Annotation ann) Doc (Annotation ann)
@ -132,9 +132,9 @@ printDiagnostic ::
-- | The handle onto which to output the diagnostic. -- | The handle onto which to output the diagnostic.
Handle -> Handle ->
-- | Should we print with unicode characters? -- | Should we print with unicode characters?
Bool -> WithUnicode ->
-- | The number of spaces each TAB character will span. -- | The number of spaces each TAB character will span.
Int -> TabSize ->
-- | The style in which to output the diagnostic. -- | The style in which to output the diagnostic.
Style ann -> Style ann ->
-- | The diagnostic to output. -- | The diagnostic to output.
@ -151,9 +151,9 @@ printDiagnostic' ::
-- | The handle onto which to output the diagnostic. -- | The handle onto which to output the diagnostic.
Handle -> Handle ->
-- | Should we print with unicode characters? -- | Should we print with unicode characters?
Bool -> WithUnicode ->
-- | The number of spaces each TAB character will span. -- | The number of spaces each TAB character will span.
Int -> TabSize ->
-- | The style in which to output the diagnostic. -- | The style in which to output the diagnostic.
Style ann -> Style ann ->
-- | The diagnostic to output. -- | The diagnostic to output.

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

@ -26,6 +26,8 @@
module Error.Diagnose.Report.Internal module Error.Diagnose.Report.Internal
( module Error.Diagnose.Report.Internal ( module Error.Diagnose.Report.Internal
, Report(.., Warn, Err) , Report(.., Warn, Err)
, WithUnicode(..)
, TabSize(..)
) where ) where
#ifdef USE_AESON #ifdef USE_AESON
@ -52,6 +54,7 @@ import Error.Diagnose.Position
import Error.Diagnose.Style (Annotation (..)) import Error.Diagnose.Style (Annotation (..))
import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>), reAnnotate) import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>), reAnnotate)
import Prettyprinter.Internal (Doc (..)) import Prettyprinter.Internal (Doc (..))
import Data.Bool (bool)
type FileMap = HashMap FilePath (Array Int String) type FileMap = HashMap FilePath (Array Int String)
@ -193,14 +196,18 @@ errorToWarning :: Report msg -> Report msg
errorToWarning (Report True code msg markers notes) = Report False code msg markers notes errorToWarning (Report True code msg markers notes) = Report False code msg markers notes
errorToWarning r@(Report False _ _ _ _) = r errorToWarning r@(Report False _ _ _ _) = r
data WithUnicode = WithoutUnicode | WithUnicode
newtype TabSize = TabSize Int
-- | Pretty prints a report to a 'Doc' handling colors. -- | Pretty prints a report to a 'Doc' handling colors.
prettyReport :: prettyReport ::
-- | The content of the file the reports are for -- | The content of the file the reports are for
FileMap -> FileMap ->
-- | Should we print paths in unicode? -- | Should we print paths in unicode?
Bool -> WithUnicode ->
-- | The number of spaces each TAB character will span -- | The number of spaces each TAB character will span
Int -> TabSize ->
-- | The whole report to output -- | The whole report to output
Report (Doc ann) -> Report (Doc ann) ->
Doc (Annotation ann) Doc (Annotation ann)
@ -251,7 +258,7 @@ prettyReport fileContent withUnicode tabSize (Report isError code message marker
<> {- (6) -} ( if null markers && null hints <> {- (6) -} ( if null markers && null hints
then mempty then mempty
else else
annotate RuleColor (pad (maxLineNumberLength + 2) (if withUnicode then '─' else '-') mempty <> if withUnicode then "╯" else "+") annotate RuleColor (pad (maxLineNumberLength + 2) (unicode '-' '─' withUnicode) mempty <> unicode "+" "╯" withUnicode)
<> hardline <> hardline
) )
@ -273,9 +280,11 @@ dotPrefix ::
-- | The length of the left space before the bullet. -- | The length of the left space before the bullet.
Int -> Int ->
-- | Whether to print with unicode characters or not. -- | Whether to print with unicode characters or not.
Bool -> WithUnicode ->
Doc (Annotation ann) Doc (Annotation ann)
dotPrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (if withUnicode then "•" else ":") dotPrefix leftLen withUnicode =
pad leftLen ' ' mempty
<+> annotate RuleColor (unicode ":" "•" withUnicode)
{-# INLINE dotPrefix #-} {-# INLINE dotPrefix #-}
-- | Creates a "pipe"-prefix for a report line where there is no code. -- | Creates a "pipe"-prefix for a report line where there is no code.
@ -288,9 +297,9 @@ pipePrefix ::
-- | The length of the left space before the pipe. -- | The length of the left space before the pipe.
Int -> Int ->
-- | Whether to print with unicode characters or not. -- | Whether to print with unicode characters or not.
Bool -> WithUnicode ->
Doc (Annotation ann) Doc (Annotation ann)
pipePrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (if withUnicode then "│" else "|") pipePrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate RuleColor (unicode "|" "│" withUnicode)
{-# INLINE pipePrefix #-} {-# INLINE pipePrefix #-}
-- | Creates a line-prefix for a report line containing source code -- | Creates a line-prefix for a report line containing source code
@ -307,11 +316,11 @@ linePrefix ::
-- | The line number to show. -- | The line number to show.
Int -> Int ->
-- | Whether to use unicode characters or not. -- | Whether to use unicode characters or not.
Bool -> WithUnicode ->
Doc (Annotation ann) Doc (Annotation ann)
linePrefix leftLen lineNo withUnicode = linePrefix leftLen lineNo withUnicode =
let lineNoLen = length (show lineNo) let lineNoLen = length (show lineNo)
in annotate RuleColor $ mempty <+> pad (leftLen - lineNoLen) ' ' mempty <> pretty lineNo <+> if withUnicode then "│" else "|" in annotate RuleColor $ mempty <+> pad (leftLen - lineNoLen) ' ' mempty <> pretty lineNo <+> unicode "|" "│" withUnicode
{-# INLINE linePrefix #-} {-# INLINE linePrefix #-}
-- | Creates an ellipsis-prefix, when some line numbers are not consecutive. -- | Creates an ellipsis-prefix, when some line numbers are not consecutive.
@ -322,9 +331,9 @@ linePrefix leftLen lineNo withUnicode =
-- [without unicode] "@␣␣␣␣...@" -- [without unicode] "@␣␣␣␣...@"
ellipsisPrefix :: ellipsisPrefix ::
Int -> Int ->
Bool -> WithUnicode ->
Doc (Annotation ann) Doc (Annotation ann)
ellipsisPrefix leftLen withUnicode = pad leftLen ' ' mempty <> annotate RuleColor (if withUnicode then space <> "⋮" else "...") ellipsisPrefix leftLen withUnicode = pad leftLen ' ' mempty <> annotate RuleColor (unicode "..." (space <> "⋮") withUnicode)
groupMarkersPerFile :: groupMarkersPerFile ::
[(Position, Marker msg)] -> [(Position, Marker msg)] ->
@ -353,11 +362,11 @@ prettySubReport ::
-- | The content of files in the diagnostics -- | The content of files in the diagnostics
FileMap -> FileMap ->
-- | Is the output done with Unicode characters? -- | Is the output done with Unicode characters?
Bool -> WithUnicode ->
-- | Is the current report an error report? -- | Is the current report an error report?
Bool -> Bool ->
-- | The number of spaces each TAB character will span -- | The number of spaces each TAB character will span
Int -> TabSize ->
-- | The size of the biggest line number -- | The size of the biggest line number
Int -> Int ->
-- | Is this sub-report the first one in the list? -- | Is this sub-report the first one in the list?
@ -380,16 +389,16 @@ prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength isFi
( if isFirst ( if isFirst
then then
space <> pad maxLineNumberLength ' ' mempty space <> pad maxLineNumberLength ' ' mempty
<+> annotate RuleColor (if withUnicode then "╭──▶" else "+-->") <+> annotate RuleColor (unicode "+-->" "╭──▶" withUnicode)
else else
space <> dotPrefix maxLineNumberLength withUnicode <> hardline space <> dotPrefix maxLineNumberLength withUnicode <> hardline
<> annotate RuleColor (pad (maxLineNumberLength + 2) (if withUnicode then '─' else '-') mempty) <> annotate RuleColor (pad (maxLineNumberLength + 2) (unicode '-' '─' withUnicode) mempty)
<> annotate RuleColor (if withUnicode then "┼──▶" else "+-->") <> annotate RuleColor (unicode "+-->" "┼──▶" withUnicode)
) )
<+> annotate FileColor reportFile <+> annotate FileColor reportFile
in {- (2) -} hardline <> fileMarker in {- (2) -} hardline <> fileMarker
<> hardline <> hardline
<+> {- (3) -} pipePrefix maxLineNumberLength withUnicode <+> {- (3) -} {- (3) -} pipePrefix maxLineNumberLength withUnicode
<> {- (4) -} prettyAllLines fileContent withUnicode isError tabSize maxLineNumberLength sortedMarkersPerLine multilineMarkers allLineNumbers <> {- (4) -} prettyAllLines fileContent withUnicode isError tabSize maxLineNumberLength sortedMarkersPerLine multilineMarkers allLineNumbers
isThisMarker :: Marker msg -> Bool isThisMarker :: Marker msg -> Bool
@ -408,10 +417,10 @@ splitMarkersPerLine (m@(Position {..}, _) : ms) =
-- | -- |
prettyAllLines :: prettyAllLines ::
FileMap -> FileMap ->
Bool -> WithUnicode ->
Bool -> Bool ->
-- | The number of spaces each TAB character will span -- | The number of spaces each TAB character will span
Int -> TabSize ->
Int -> Int ->
[(Int, [(Position, Marker (Doc ann))])] -> [(Int, [(Position, Marker (Doc ann))])] ->
[(Position, Marker (Doc ann))] -> [(Position, Marker (Doc ann))] ->
@ -458,19 +467,14 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu
if not $ null multiline if not $ null multiline
then then
if not $ null allMultilineMarkersSpanningLine if not $ null allMultilineMarkersSpanningLine
then colorOfFirstMultilineMarker if withUnicode then "│ " else "| " then colorOfFirstMultilineMarker (unicode "| " "│ " withUnicode)
else " " else " "
else mempty else mempty
(p@(Position _ (el, _) _), marker) : _ -> (p@(Position _ (el, _) _), marker) : _ ->
let hasPredecessor = el == line || maybe False ((/=) p . fst . fst) (List.safeUncons multiline) let hasPredecessor = el == line || maybe False ((/=) p . fst . fst) (List.safeUncons multiline)
in colorOfFirstMultilineMarker in colorOfFirstMultilineMarker
( if (unicode (bool "+" "|" hasPredecessor ) (bool "╭" "├" hasPredecessor) withUnicode)
| hasPredecessor && withUnicode -> "├" <> annotate (markerColor isError marker) (unicode ">" "┤" withUnicode)
| hasPredecessor -> "|"
| withUnicode -> "╭"
| otherwise -> "+"
)
<> annotate (markerColor isError marker) (if withUnicode then "┤" else ">")
<> space <> space
-- we need to remove all blank markers because they are irrelevant to the display -- we need to remove all blank markers because they are irrelevant to the display
@ -480,7 +484,7 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu
(widths, renderedCode) = getLine_ files (allInlineMarkersInLine <> allMultilineMarkersInLine <> allMultilineMarkersSpanningLine') line tabSize isError (widths, renderedCode) = getLine_ files (allInlineMarkersInLine <> allMultilineMarkersInLine <> allMultilineMarkersSpanningLine') line tabSize isError
in ( otherMultilines, in ( otherMultilines,
hardline hardline
<> {- (1) -} linePrefix leftLen line withUnicode <+> additionalPrefix <> {- (1) -} linePrefix leftLen line withUnicode <+> additionalPrefix
<> renderedCode <> renderedCode
<> {- (2) -} showAllMarkersInLine (not $ null multiline) inSpanOfMultiline colorOfFirstMultilineMarker withUnicode isError leftLen widths allInlineMarkersInLine' <> {- (2) -} showAllMarkersInLine (not $ null multiline) inSpanOfMultiline colorOfFirstMultilineMarker withUnicode isError leftLen widths allInlineMarkersInLine'
<> showMultiline (isLastLine || List.safeLast multilineEndingOnLine == List.safeLast multiline) multilineEndingOnLine <> showMultiline (isLastLine || List.safeLast multilineEndingOnLine == List.safeLast multiline) multilineEndingOnLine
@ -493,14 +497,14 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu
prefix = hardline <+> dotPrefix leftLen withUnicode <> space prefix = hardline <+> dotPrefix leftLen withUnicode <> space
prefixWithBar color = prefix <> maybe id annotate color (if withUnicode then "│ " else "| ") prefixWithBar color = prefix <> maybe id annotate color (unicode "| " "│ " withUnicode)
showMultilineMarkerMessage (_, Blank) _ = mempty showMultilineMarkerMessage (_, Blank) _ = mempty
showMultilineMarkerMessage (_, marker) isLast = showMultilineMarkerMessage (_, marker) isLast =
annotate (markerColor isError marker) $ annotate (markerColor isError marker) $
( if isLast && isLastMultiline ( if isLast && isLastMultiline
then if withUnicode then "╰╸ " else "`- " then unicode "`- " "╰╸ " withUnicode
else if withUnicode then "├╸ " else "|- " 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) (annotated $ markerMessage marker)
@ -514,10 +518,10 @@ getLine_ ::
FileMap -> FileMap ->
[(Position, Marker msg)] -> [(Position, Marker msg)] ->
Int -> Int ->
Int -> TabSize ->
Bool -> Bool ->
(WidthTable, Doc (Annotation ann)) (WidthTable, Doc (Annotation ann))
getLine_ files markers line tabSize isError = getLine_ files markers line (TabSize tabSize) isError =
case safeArrayIndex (line - 1) =<< (HashMap.!?) files . file . fst =<< List.safeHead markers of case safeArrayIndex (line - 1) =<< (HashMap.!?) files . file . fst =<< List.safeHead markers of
Nothing -> Nothing ->
( mkWidthTable "", ( mkWidthTable "",
@ -550,12 +554,12 @@ getLine_ files markers line tabSize isError =
mkWidthTable s = listArray (1, length s) (ifTab tabSize wcwidth <$> s) mkWidthTable s = listArray (1, length s) (ifTab tabSize wcwidth <$> s)
-- | -- |
showAllMarkersInLine :: Bool -> Bool -> (Doc (Annotation ann) -> Doc (Annotation ann)) -> Bool -> Bool -> Int -> WidthTable -> [(Position, Marker (Doc ann))] -> Doc (Annotation ann) showAllMarkersInLine :: Bool -> Bool -> (Doc (Annotation ann) -> Doc (Annotation ann)) -> WithUnicode -> Bool -> Int -> WidthTable -> [(Position, Marker (Doc ann))] -> Doc (Annotation ann)
showAllMarkersInLine _ _ _ _ _ _ _ [] = mempty showAllMarkersInLine _ _ _ _ _ _ _ [] = mempty
showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUnicode isError leftLen widths ms = showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUnicode isError leftLen widths ms =
let maxMarkerColumn = snd $ end $ fst $ List.last $ List.sortOn (snd . end . fst) ms let maxMarkerColumn = snd $ end $ fst $ List.last $ List.sortOn (snd . end . fst) ms
specialPrefix specialPrefix
| inSpanOfMultiline = colorMultilinePrefix (if withUnicode then "│ " else "| ") <> space | inSpanOfMultiline = colorMultilinePrefix (unicode "| " "│ " withUnicode) <> space
| hasMultilines = colorMultilinePrefix " " <> space | hasMultilines = colorMultilinePrefix " " <> space
| otherwise = mempty | otherwise = mempty
in -- get the maximum end column, so that we know when to stop looking for other markers on the same line in -- get the maximum end column, so that we know when to stop looking for other markers on the same line
@ -576,8 +580,8 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn
annotate annotate
(markerColor isError marker) (markerColor isError marker)
( if snd begin == n ( if snd begin == n
then (if withUnicode then "┬" else "^") <> fold (replicate (widthAt n - 1) if withUnicode then "─" else "-") then unicode "^" "┬" withUnicode <> fold (replicate (widthAt n - 1) (unicode "-" "─" withUnicode))
else fold (replicate (widthAt n) if withUnicode then "─" else "-") else fold (replicate (widthAt n) (unicode "-" "─" withUnicode))
) )
<> showMarkers (n + 1) lineLen <> showMarkers (n + 1) lineLen
@ -608,7 +612,7 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn
let (pipesBefore, pipesAfter) = List.partition ((< bc) . snd . begin . fst) nubbedPipes let (pipesBefore, pipesAfter) = List.partition ((< bc) . snd . begin . fst) nubbedPipes
-- split the list so that all pipes before can have `|`s but pipes after won't -- split the list so that all pipes before can have `|`s but pipes after won't
pipesBeforeRendered = pipesBefore <&> second \marker -> annotate (markerColor isError marker) (if withUnicode then "│" else "|") pipesBeforeRendered = pipesBefore <&> second \marker -> annotate (markerColor isError marker) (unicode "|" "│" withUnicode)
-- pre-render pipes which are before because they will be shown -- pre-render pipes which are before because they will be shown
lastBeginPosition = snd . begin . fst <$> List.safeLast (List.sortOn (snd . begin . fst) pipesAfter) lastBeginPosition = snd . begin . fst <$> List.safeLast (List.sortOn (snd . begin . fst) pipesAfter)
@ -617,20 +621,15 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn
Nothing -> 0 Nothing -> 0
Just col -> widthsBetween bc col Just col -> widthsBetween bc col
currentPipe = currentPipe = unicode (bool "`" "|" hasSuccessor) (bool "╰" "├" hasSuccessor) withUnicode
if
| withUnicode && hasSuccessor -> "├"
| withUnicode -> "╰"
| hasSuccessor -> "|"
| otherwise -> "`"
lineChar = if withUnicode then '─' else '-' lineChar = unicode '-' '─' withUnicode
pointChar = if withUnicode then "╸" else "-" pointChar = unicode "-" "╸" withUnicode
bc' = bc + lineLen + 2 bc' = bc + lineLen + 2
pipesBeforeMessageStart = List.filter ((< bc') . snd . begin . fst) pipesAfter pipesBeforeMessageStart = List.filter ((< bc') . snd . begin . fst) pipesAfter
-- consider pipes before, as well as pipes which came before the text rectangle bounds -- consider pipes before, as well as pipes which came before the text rectangle bounds
pipesBeforeMessageRendered = (pipesBefore <> pipesBeforeMessageStart) <&> second \marker -> annotate (markerColor isError marker) (if withUnicode then "│" else "|") pipesBeforeMessageRendered = (pipesBefore <> pipesBeforeMessageStart) <&> second \marker -> annotate (markerColor isError marker) (unicode "|" "│" withUnicode)
in -- also pre-render pipes which are before the message text bounds, because they will be shown if the message is on in -- also pre-render pipes which are before the message text bounds, because they will be shown if the message is on
-- multiple lines -- multiple lines
@ -685,7 +684,7 @@ markerMessage Blank = undefined
{-# INLINE markerMessage #-} {-# INLINE markerMessage #-}
-- | Pretty prints all hints. -- | Pretty prints all hints.
prettyAllHints :: [Note (Doc ann)] -> Int -> Bool -> Doc (Annotation ann) prettyAllHints :: [Note (Doc ann)] -> Int -> WithUnicode -> Doc (Annotation ann)
prettyAllHints [] _ _ = mempty prettyAllHints [] _ _ = mempty
prettyAllHints (h : hs) leftLen withUnicode = prettyAllHints (h : hs) leftLen withUnicode =
{- {-
@ -709,3 +708,8 @@ safeArrayIndex i a
annotated :: Doc ann -> Doc (Annotation ann) annotated :: Doc ann -> Doc (Annotation ann)
annotated = reAnnotate OtherStyle annotated = reAnnotate OtherStyle
unicode :: a -> a -> WithUnicode -> a
unicode f t = \case
WithoutUnicode -> f
WithUnicode -> t

6
test/megaparsec/Repro6.hs
View File

@ -44,12 +44,12 @@ main = do
content3 content3
case res1 of case res1 of
Left diag -> printDiagnostic stdout True 4 defaultStyle (addFile diag filename (Text.unpack content1) :: Diagnostic String) Left diag -> printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle (addFile diag filename (Text.unpack content1) :: Diagnostic String)
Right res -> print res Right res -> print res
case res2 of case res2 of
Left diag -> printDiagnostic stdout True 4 defaultStyle (addFile diag filename (Text.unpack content2) :: Diagnostic String) Left diag -> printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle (addFile diag filename (Text.unpack content2) :: Diagnostic String)
Right res -> print res Right res -> print res
putStrLn "------------- res3 ----------------" putStrLn "------------- res3 ----------------"
case res3 of case res3 of
Left diag -> printDiagnostic stdout True 4 defaultStyle (addFile diag filename (Text.unpack content3) :: Diagnostic String) Left diag -> printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle (addFile diag filename (Text.unpack content3) :: Diagnostic String)
Right res -> print res Right res -> print res

8
test/megaparsec/Spec.hs
View File

@ -29,11 +29,11 @@ main = do
res2 = first (errorDiagnosticFromBundle Nothing "Parse error on input" Nothing) $ MP.runParser @Void (MP.some MP.decimal <* MP.eof) filename content2 res2 = first (errorDiagnosticFromBundle Nothing "Parse error on input" Nothing) $ MP.runParser @Void (MP.some MP.decimal <* MP.eof) filename content2
case res1 of case res1 of
Left diag -> printDiagnostic stdout True 4 defaultStyle (addFile diag filename (Text.unpack content1) :: Diagnostic String) Left diag -> printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle (addFile diag filename (Text.unpack content1) :: Diagnostic String)
Right res -> print res Right res -> print @[Integer] res
case res2 of case res2 of
Left diag -> printDiagnostic stdout True 4 defaultStyle (addFile diag filename (Text.unpack content2) :: Diagnostic String) Left diag -> printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle (addFile diag filename (Text.unpack content2) :: Diagnostic String)
Right res -> print res Right res -> print @[Integer] res
putStrLn "---------------------------------------------------" putStrLn "---------------------------------------------------"

4
test/parsec/Repro2.hs
View File

@ -29,8 +29,8 @@ parser2 = op' "\\" *> letter
main :: IO () main :: IO ()
main = do main = do
either (printDiagnostic stderr True 4 defaultStyle) print $ diagParse parser1 "issues/2.txt" "\\1" either (printDiagnostic stderr WithUnicode (TabSize 4) defaultStyle) print $ diagParse parser1 "issues/2.txt" "\\1"
either (printDiagnostic stderr True 4 defaultStyle) print $ diagParse parser2 "issues/2.txt" "\\1" either (printDiagnostic stderr WithUnicode (TabSize 4) defaultStyle) print $ diagParse parser2 "issues/2.txt" "\\1"
-- smaller example -- smaller example
op' :: String -> Parser String op' :: String -> Parser String

6
test/parsec/Spec.hs
View File

@ -32,13 +32,13 @@ main = do
res3 = first (errorDiagnosticFromParseError Nothing "Parse error on input" Nothing) $ P.parse (test1 <* P.eof) filename content3 res3 = first (errorDiagnosticFromParseError Nothing "Parse error on input" Nothing) $ P.parse (test1 <* P.eof) filename content3
case res1 of case res1 of
Left diag -> printDiagnostic stdout True 4 defaultStyle (addFile diag filename (Text.unpack content1) :: Diagnostic String) Left diag -> printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle (addFile diag filename (Text.unpack content1) :: Diagnostic String)
Right res -> print res Right res -> print res
case res2 of case res2 of
Left diag -> printDiagnostic stdout True 4 defaultStyle (addFile diag filename (Text.unpack content2) :: Diagnostic String) Left diag -> printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle (addFile diag filename (Text.unpack content2) :: Diagnostic String)
Right res -> print res Right res -> print res
case res3 of case res3 of
Left diag -> printDiagnostic stdout True 4 defaultStyle (addFile diag filename (Text.unpack content3) :: Diagnostic String) Left diag -> printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle (addFile diag filename (Text.unpack content3) :: Diagnostic String)
Right res -> print res Right res -> print res
-- all issue reproduction -- all issue reproduction

6
test/rendering/Spec.hs
View File

@ -17,6 +17,8 @@ import Error.Diagnose
defaultStyle, defaultStyle,
printDiagnostic, printDiagnostic,
stdout, stdout,
WithUnicode (..),
TabSize (..),
) )
import System.IO (hPutStrLn) import System.IO (hPutStrLn)
@ -77,9 +79,9 @@ main = do
let diag = HashMap.foldlWithKey' addFile (foldl addReport def reports) files let diag = HashMap.foldlWithKey' addFile (foldl addReport def reports) files
hPutStrLn stdout "\n\nWith unicode: ─────────────────────────\n" hPutStrLn stdout "\n\nWith unicode: ─────────────────────────\n"
printDiagnostic stdout True 4 defaultStyle diag printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle diag
hPutStrLn stdout "\n\nWithout unicode: ----------------------\n" hPutStrLn stdout "\n\nWithout unicode: ----------------------\n"
printDiagnostic stdout False 4 defaultStyle diag printDiagnostic stdout WithoutUnicode (TabSize 4) defaultStyle diag
#ifdef USE_AESON #ifdef USE_AESON
hPutStrLn stdout "\n\nAs JSON: ------------------------------\n" hPutStrLn stdout "\n\nAs JSON: ------------------------------\n"
BS.hPutStr stdout (diagnosticToJson diag) BS.hPutStr stdout (diagnosticToJson diag)