Make interface a little more typesafe with WithUnicode and TabSize

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

View File

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

View File

@ -16,7 +16,7 @@
-- It is also highly undocumented.
--
-- 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)
#ifdef USE_AESON
@ -32,7 +32,7 @@ import Data.Foldable (fold, toList)
import qualified Data.HashMap.Lazy as HashMap
import Data.List (intersperse)
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 Prettyprinter (Doc, Pretty, hardline, pretty, defaultLayoutOptions, reAnnotateS, layoutPretty)
import Prettyprinter.Render.Terminal (renderIO)
@ -102,9 +102,9 @@ errorsToWarnings (Diagnostic reports files) = Diagnostic (errorToWarning <$> rep
prettyDiagnostic ::
Pretty msg =>
-- | Should we use unicode when printing paths?
Bool ->
WithUnicode ->
-- | The number of spaces each TAB character will span.
Int ->
TabSize ->
-- | The diagnostic to print.
Diagnostic msg ->
Doc (Annotation ann)
@ -117,9 +117,9 @@ prettyDiagnostic withUnicode tabSize =
-- annotations are retained in 'OtherStyle'
prettyDiagnostic' ::
-- | Should we use unicode when printing paths?
Bool ->
WithUnicode ->
-- | The number of spaces each TAB character will span.
Int ->
TabSize ->
-- | The diagnostic to print.
Diagnostic (Doc ann) ->
Doc (Annotation ann)
@ -132,9 +132,9 @@ printDiagnostic ::
-- | The handle onto which to output the diagnostic.
Handle ->
-- | Should we print with unicode characters?
Bool ->
WithUnicode ->
-- | The number of spaces each TAB character will span.
Int ->
TabSize ->
-- | The style in which to output the diagnostic.
Style ann ->
-- | The diagnostic to output.
@ -151,9 +151,9 @@ printDiagnostic' ::
-- | The handle onto which to output the diagnostic.
Handle ->
-- | Should we print with unicode characters?
Bool ->
WithUnicode ->
-- | The number of spaces each TAB character will span.
Int ->
TabSize ->
-- | The style in which to output the diagnostic.
Style ann ->
-- | The diagnostic to output.

View File

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

View File

@ -44,12 +44,12 @@ main = do
content3
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
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
putStrLn "------------- res3 ----------------"
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

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
case res1 of
Left diag -> printDiagnostic stdout True 4 defaultStyle (addFile diag filename (Text.unpack content1) :: Diagnostic String)
Right res -> print res
Left diag -> printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle (addFile diag filename (Text.unpack content1) :: Diagnostic String)
Right res -> print @[Integer] res
case res2 of
Left diag -> printDiagnostic stdout True 4 defaultStyle (addFile diag filename (Text.unpack content2) :: Diagnostic String)
Right res -> print res
Left diag -> printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle (addFile diag filename (Text.unpack content2) :: Diagnostic String)
Right res -> print @[Integer] res
putStrLn "---------------------------------------------------"

View File

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

View File

@ -32,13 +32,13 @@ main = do
res3 = first (errorDiagnosticFromParseError Nothing "Parse error on input" Nothing) $ P.parse (test1 <* P.eof) filename content3
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
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
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
-- all issue reproduction

View File

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