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

Merge pull request #21 from expipiplus1/doc-message

Browse Source 
Add functionality to render diagnostics with user provided Docs
This commit is contained in:
Mesabloo 2023-06-02 21:01:02 +02:00 committed by GitHub
commit 26266751bc
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
13 changed files with 330 additions and 158 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
README.md
View File

@ -102,8 +102,8 @@ let beautifulExample =
let diagnostic = addFile def "somefile.zc" "let id<a>(x : a) : a := x\n + 1" let diagnostic = addFile def "somefile.zc" "let id<a>(x : a) : a := x\n + 1"
let diagnostic' = addReport diagnostic beautifulExample let diagnostic' = addReport diagnostic beautifulExample
-- Print with unicode characters, colors and the default style -- Print with unicode characters, and the default (colorful) style
printDiagnostic stdout True True 4 defaultStyle diagnostic' printDiagnostic stdout WithUnicode 4 defaultStyle diagnostic'
``` ```
More examples are given in the [`test/rendering`](./test/rendering) folder (execute `stack test` to see the output). More examples are given in the [`test/rendering`](./test/rendering) folder (execute `stack test` to see the output).

2
diagnose.cabal
View File

@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
name: diagnose name: diagnose
version: 2.4.0 version: 2.5.0
synopsis: Beautiful error reporting done easily synopsis: Beautiful error reporting done easily
description: This package provides a simple way of getting beautiful compiler/interpreter errors description: This package provides a simple way of getting beautiful compiler/interpreter errors
using a very simple interface for the programmer. using a very simple interface for the programmer.

4
src/Error/Diagnose.hs
View File

@ -241,7 +241,7 @@ import Error.Diagnose.Style as Export
-- > -- Creates a new diagnostic with no default hints from the bundle returned by megaparsec -- > -- Creates a new diagnostic with no default hints from the bundle returned by megaparsec
-- > diag' = addFile diag filename content -- > diag' = addFile diag filename content
-- > -- Add the file used when parsing with the same filename given to 'MP.runParser' -- > -- Add the file used when parsing with the same filename given to 'MP.runParser'
-- > in printDiagnostic stderr True True 4 diag' -- > in printDiagnostic stderr True 4 diag'
-- > Right res -> print res -- > Right res -> print res
-- --
-- This example will return the following error message (assuming default instances for @'Error.Diagnose.Compat.Megaparsec.HasHints' 'Data.Void.Void' msg@): -- This example will return the following error message (assuming default instances for @'Error.Diagnose.Compat.Megaparsec.HasHints' 'Data.Void.Void' msg@):
@ -282,7 +282,7 @@ import Error.Diagnose.Style as Export
-- > -- Creates a new diagnostic with no default hints from the bundle returned by megaparsec -- > -- Creates a new diagnostic with no default hints from the bundle returned by megaparsec
-- > diag' = addFile diag filename content -- > diag' = addFile diag filename content
-- > -- Add the file used when parsing with the same filename given to 'MP.runParser' -- > -- Add the file used when parsing with the same filename given to 'MP.runParser'
-- > in printDiagnostic stderr True True 4 diag' -- > in printDiagnostic stderr True 4 diag'
-- > Right res -> print res -- > Right res -> print res
-- --
-- This will output the following error on @stderr@: -- This will output the following error on @stderr@:

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

@ -25,7 +25,11 @@ import Error.Diagnose.Diagnostic.Internal as Export
hasReports, hasReports,
reportsOf, reportsOf,
prettyDiagnostic, prettyDiagnostic,
prettyDiagnostic',
printDiagnostic, printDiagnostic,
printDiagnostic',
warningsToErrors, warningsToErrors,
WithUnicode(..),
TabSize(..),
) )
import System.IO as Export (stderr, stdout) import System.IO as Export (stderr, stdout)

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

@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
-- | -- |
@ -13,7 +14,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
@ -29,10 +30,10 @@ 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, unAnnotate) import Prettyprinter (Doc, Pretty, hardline, pretty, defaultLayoutOptions, reAnnotateS, layoutPretty)
import Prettyprinter.Render.Terminal (hPutDoc) import Prettyprinter.Render.Terminal (renderIO)
import System.IO (Handle) import System.IO (Handle)
-- | The data type for diagnostic containing messages of an abstract type. -- | The data type for diagnostic containing messages of an abstract type.
@ -47,6 +48,7 @@ data Diagnostic msg
-- Reports are output one by one, without connections in between. -- Reports are output one by one, without connections in between.
!FileMap !FileMap
-- ^ A map associating files with their content as lists of lines. -- ^ A map associating files with their content as lists of lines.
deriving (Functor, Foldable, Traversable)
instance Default (Diagnostic msg) where instance Default (Diagnostic msg) where
def = Diagnostic mempty mempty def = Diagnostic mempty mempty
@ -98,36 +100,70 @@ 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 Doc (Annotation ann)
prettyDiagnostic withUnicode tabSize (Diagnostic reports file) = prettyDiagnostic withUnicode tabSize =
fold . intersperse hardline $ prettyReport file withUnicode tabSize <$> toList reports prettyDiagnostic' withUnicode tabSize . fmap pretty
{-# INLINE prettyDiagnostic #-} {-# INLINE prettyDiagnostic #-}
-- | Like 'prettyDiagnostic' except that instead of requiring a 'pretty'
-- instance for messages, this allows passing in your own 'Doc'. Custom
-- annotations are retained in 'OtherStyle'
prettyDiagnostic' ::
-- | Should we use unicode when printing paths?
WithUnicode ->
-- | The number of spaces each TAB character will span.
TabSize ->
-- | The diagnostic to print.
Diagnostic (Doc ann) ->
Doc (Annotation ann)
prettyDiagnostic' withUnicode tabSize (Diagnostic reports file) =
fold . intersperse hardline $ prettyReport file withUnicode tabSize <$> toList reports
-- | Prints a 'Diagnostic' onto a specific 'Handle'. -- | Prints a 'Diagnostic' onto a specific 'Handle'.
printDiagnostic :: printDiagnostic ::
(MonadIO m, Pretty msg) => (MonadIO m, Pretty msg) =>
-- | 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 ->
-- | 'False' to disable colors.
Bool ->
-- | 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 -> Style ann ->
-- | The diagnostic to output. -- | The diagnostic to output.
Diagnostic msg -> Diagnostic msg ->
m () m ()
printDiagnostic handle withUnicode withColors tabSize style diag = printDiagnostic handle withUnicode tabSize style =
liftIO $ hPutDoc handle ((if withColors then style else unAnnotate) $ prettyDiagnostic withUnicode tabSize diag) printDiagnostic' handle withUnicode tabSize style . fmap pretty
{-# INLINE printDiagnostic #-} {-# INLINE printDiagnostic #-}
-- | Like 'printDiagnostic' except that instead of requiring a 'pretty'
-- instance for messages, this allows passing in your own 'Doc'.
printDiagnostic' ::
MonadIO m =>
-- | The handle onto which to output the diagnostic.
Handle ->
-- | Should we print with unicode characters?
WithUnicode ->
-- | The number of spaces each TAB character will span.
TabSize ->
-- | The style in which to output the diagnostic.
Style ann ->
-- | The diagnostic to output.
Diagnostic (Doc ann) ->
m ()
printDiagnostic' handle withUnicode tabSize style =
liftIO
. renderIO handle
. reAnnotateS style
. layoutPretty defaultLayoutOptions
. prettyDiagnostic' withUnicode tabSize
-- | Inserts a new referenceable file within the diagnostic. -- | Inserts a new referenceable file within the diagnostic.
addFile :: addFile ::
Diagnostic msg -> Diagnostic msg ->

1
src/Error/Diagnose/Pretty.hs
View File

@ -1,4 +1,3 @@
module Error.Diagnose.Pretty (module Export) where module Error.Diagnose.Pretty (module Export) where
import qualified Prettyprinter as Export import qualified Prettyprinter as Export
import qualified Prettyprinter.Render.Terminal as Export

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

@ -1,5 +1,6 @@
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
@ -23,6 +24,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
@ -47,8 +50,9 @@ import Data.String (IsString (fromString))
import qualified Data.Text as Text import qualified Data.Text as Text
import Error.Diagnose.Position 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, (<+>)) import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>), reAnnotate, SimpleDocStream (..), layoutCompact)
import Prettyprinter.Internal (Doc (..)) import Prettyprinter.Internal (Doc (..), textSpaces)
import Data.Bool (bool)
type FileMap = HashMap FilePath (Array Int String) type FileMap = HashMap FilePath (Array Int String)
@ -67,6 +71,7 @@ data Report msg
-- ^ A map associating positions with marker to show under the source code. -- ^ A map associating positions with marker to show under the source code.
[Note msg] [Note msg]
-- ^ A list of notes to add at the end of the report. -- ^ A list of notes to add at the end of the report.
deriving (Functor, Foldable, Traversable)
-- | Pattern synonym for a warning report. -- | Pattern synonym for a warning report.
pattern Warn :: Maybe msg -> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg pattern Warn :: Maybe msg -> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
@ -120,6 +125,7 @@ data Marker msg
Maybe msg Maybe msg
| -- | An empty marker, whose sole purpose is to include a line of code in the report without markers under. | -- | An empty marker, whose sole purpose is to include a line of code in the report without markers under.
Blank Blank
deriving (Functor, Foldable, Traversable)
instance Eq (Marker msg) where instance Eq (Marker msg) where
This _ == This _ = True This _ == This _ = True
@ -147,6 +153,7 @@ data Note msg
Note msg Note msg
| -- | A hint, to propose potential fixes or help towards fixing the issue. | -- | A hint, to propose potential fixes or help towards fixing the issue.
Hint msg Hint msg
deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
#ifdef USE_AESON #ifdef USE_AESON
instance ToJSON msg => ToJSON (Note msg) where instance ToJSON msg => ToJSON (Note msg) where
@ -187,18 +194,21 @@ 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 ::
Pretty msg =>
-- | 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 msg -> Report (Doc ann) ->
Doc Annotation Doc (Annotation ann)
prettyReport fileContent withUnicode tabSize (Report isError code message markers hints) = prettyReport fileContent withUnicode tabSize (Report isError code message markers hints) =
let sortedMarkers = List.sortOn (fst . begin . fst) markers 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 -- sort the markers so that the first lines of the reports are the first lines of the file
@ -219,7 +229,7 @@ prettyReport fileContent withUnicode tabSize (Report isError code message marker
) )
<> case code of <> case code of
Nothing -> rbracket Nothing -> rbracket
Just code -> space <> pretty code <> rbracket Just code -> space <> annotated code <> rbracket
) )
in {- in {-
A report is of the form: A report is of the form:
@ -234,7 +244,7 @@ prettyReport fileContent withUnicode tabSize (Report isError code message marker
(6) -------+ (6) -------+
-} -}
{- (1) -} header <> colon <+> align (pretty message) {- (1) -} header <> colon <+> align (annotated message)
<> {- (2), (3), (4) -} fold (uncurry (prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength) <$> groupedMarkers) <> {- (2), (3), (4) -} fold (uncurry (prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength) <$> groupedMarkers)
<> {- (5) -} ( if <> {- (5) -} ( if
| null hints && null markers -> mempty | null hints && null markers -> mempty
@ -246,7 +256,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
) )
@ -268,9 +278,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 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.
@ -283,9 +295,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 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
@ -302,11 +314,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 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.
@ -317,12 +329,11 @@ linePrefix leftLen lineNo withUnicode =
-- [without unicode] "@␣␣␣␣...@" -- [without unicode] "@␣␣␣␣...@"
ellipsisPrefix :: ellipsisPrefix ::
Int -> Int ->
Bool -> WithUnicode ->
Doc Annotation 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 ::
Pretty msg =>
[(Position, Marker msg)] -> [(Position, Marker msg)] ->
[(Bool, [(Position, Marker msg)])] [(Bool, [(Position, Marker msg)])]
groupMarkersPerFile [] = [] groupMarkersPerFile [] = []
@ -346,22 +357,21 @@ groupMarkersPerFile markers =
-- | Prettyprint a sub-report, which is a part of the report spanning across a single file -- | Prettyprint a sub-report, which is a part of the report spanning across a single file
prettySubReport :: prettySubReport ::
Pretty msg =>
-- | 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?
Bool -> Bool ->
-- | The list of line-ordered markers appearing in a single file -- | The list of line-ordered markers appearing in a single file
[(Position, Marker msg)] -> [(Position, Marker (Doc ann))] ->
Doc Annotation Doc (Annotation ann)
prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength isFirst markers = prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength isFirst markers =
let (markersPerLine, multilineMarkers) = splitMarkersPerLine markers let (markersPerLine, multilineMarkers) = splitMarkersPerLine markers
-- split the list on whether markers are multiline or not -- split the list on whether markers are multiline or not
@ -377,16 +387,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
@ -404,17 +414,16 @@ splitMarkersPerLine (m@(Position {..}, _) : ms) =
-- | -- |
prettyAllLines :: prettyAllLines ::
Pretty msg =>
FileMap -> FileMap ->
Bool -> WithUnicode ->
Bool -> Bool ->
-- | The number of spaces each TAB character will span -- | The number of spaces each TAB character will span
TabSize ->
Int -> Int ->
Int -> [(Int, [(Position, Marker (Doc ann))])] ->
[(Int, [(Position, Marker msg)])] -> [(Position, Marker (Doc ann))] ->
[(Position, Marker msg)] ->
[Int] -> [Int] ->
Doc Annotation Doc (Annotation ann)
prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNumbers = prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNumbers =
case lineNumbers of case lineNumbers of
[] -> [] ->
@ -456,19 +465,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
@ -489,33 +493,33 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu
let colorOfFirstMultilineMarker = markerColor isError . snd <$> List.safeHead 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 -- 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 (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) (pretty $ markerMessage marker) <> replaceLinesWith (if isLast then prefix <> " " else prefixWithBar (Just $ markerColor isError marker) <> space) 0 (annotated $ markerMessage marker)
showMultilineMarkerMessages [] = [] showMultilineMarkerMessages [] = []
showMultilineMarkerMessages [m] = [showMultilineMarkerMessage m True] showMultilineMarkerMessages [m] = [showMultilineMarkerMessage m True]
showMultilineMarkerMessages (m : ms) = showMultilineMarkerMessage m False : showMultilineMarkerMessages ms 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_ :: getLine_ ::
FileMap -> FileMap ->
[(Position, Marker msg)] -> [(Position, Marker msg)] ->
Int -> Int ->
Int -> TabSize ->
Bool -> Bool ->
(WidthTable, Doc Annotation) (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 "",
@ -548,12 +552,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 :: Pretty msg => Bool -> Bool -> (Doc Annotation -> Doc Annotation) -> Bool -> Bool -> Int -> WidthTable -> [(Position, Marker msg)] -> Doc Annotation 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
@ -574,8 +578,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
@ -606,7 +610,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)
@ -615,49 +619,56 @@ 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
lineStart pipesBeforeRendered lineStart pipesBeforeRendered
<> annotate (markerColor isError msg) (currentPipe <> pretty (replicate lineLen lineChar) <> pointChar) <> annotate (markerColor isError msg) (currentPipe <> pretty (replicate lineLen lineChar) <> pointChar)
<+> annotate (markerColor isError msg) (replaceLinesWith (hardline <+> lineStart pipesBeforeMessageRendered <+> if List.null pipesBeforeMessageStart then " " else " ") $ pretty $ markerMessage msg) <+> annotate (markerColor isError msg) (replaceLinesWith (space <> lineStart pipesBeforeMessageRendered <+> if List.null pipesBeforeMessageStart then " " else " ") 0 $ annotated $ markerMessage msg)
in hardline <+> prefix <> showMessages specialPrefix pipes lineLen in hardline <+> prefix <> showMessages specialPrefix pipes lineLen
-- WARN: uses the internal of the library -- WARN: uses the internal of the library
-- --
-- DO NOT use a wildcard here, in case the internal API exposes one more constructor -- DO NOT use a wildcard here, in case the internal API exposes one more constructor
replaceLinesWith :: Doc ann -> Int -> Doc ann -> Doc ann
-- | replaceLinesWith repl = go
replaceLinesWith :: Doc ann -> Doc ann -> Doc ann where
replaceLinesWith repl Line = repl replWidth = sdsWidth . layoutCompact $ repl
replaceLinesWith _ Fail = Fail sdsWidth = \case
replaceLinesWith _ Empty = Empty SFail -> 0
replaceLinesWith _ (Char c) = Char c SEmpty -> 0
replaceLinesWith repl (Text _ s) = SChar _ sds -> 1 + sdsWidth sds
let lines = Text.split (== '\n') s <&> \txt -> Text (Text.length txt) txt SText l _ sds -> l + sdsWidth sds
in mconcat (List.intersperse repl lines) SLine _ _ -> error "replaceLinesWith was given a prefix with a line break"
replaceLinesWith repl (FlatAlt f d) = FlatAlt (replaceLinesWith repl f) (replaceLinesWith repl d) SAnnPush _ sds -> sdsWidth sds
replaceLinesWith repl (Cat c d) = Cat (replaceLinesWith repl c) (replaceLinesWith repl d) SAnnPop sds -> sdsWidth sds
replaceLinesWith repl (Nest n d) = Nest n (replaceLinesWith repl d) replWithNesting n = hardline <> repl <> pretty (textSpaces n)
replaceLinesWith repl (Union c d) = Union (replaceLinesWith repl c) (replaceLinesWith repl d) go n = \case
replaceLinesWith repl (Column f) = Column (replaceLinesWith repl . f) Line -> replWithNesting n
replaceLinesWith repl (Nesting f) = Nesting (replaceLinesWith repl . f) Fail -> Fail
replaceLinesWith repl (Annotated ann doc) = Annotated ann (replaceLinesWith repl doc) Empty -> Empty
replaceLinesWith repl (WithPageWidth f) = WithPageWidth (replaceLinesWith repl . f) 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. -- | Extracts the color of a marker as a 'Doc' coloring function.
markerColor :: markerColor ::
@ -667,7 +678,7 @@ markerColor ::
-- | The marker to extract the color from. -- | The marker to extract the color from.
Marker msg -> Marker msg ->
-- | A function used to color a 'Doc'. -- | A function used to color a 'Doc'.
Annotation Annotation ann
markerColor isError (This _) = ThisColor isError markerColor isError (This _) = ThisColor isError
markerColor _ (Where _) = WhereColor markerColor _ (Where _) = WhereColor
markerColor _ (Maybe _) = MaybeColor markerColor _ (Maybe _) = MaybeColor
@ -683,15 +694,15 @@ markerMessage Blank = undefined
{-# INLINE markerMessage #-} {-# INLINE markerMessage #-}
-- | Pretty prints all hints. -- | Pretty prints all hints.
prettyAllHints :: Pretty msg => [Note msg] -> Int -> Bool -> Doc Annotation prettyAllHints :: [Note (Doc ann)] -> Int -> WithUnicode -> Doc (Annotation ann)
prettyAllHints [] _ _ = mempty prettyAllHints [] _ _ = mempty
prettyAllHints (h : hs) leftLen withUnicode = prettyAllHints (h : hs) leftLen withUnicode =
{- {-
A hint is composed of: A hint is composed of:
(1) : Hint: <hint message> (1) : Hint: <hint message>
-} -}
let prefix = hardline <+> pipePrefix leftLen withUnicode let prefix = space <> pipePrefix leftLen withUnicode
in prefix <+> annotate HintColor (notePrefix h <+> replaceLinesWith (prefix <+> " ") (pretty $ noteMessage h)) in hardline <> prefix <+> annotate HintColor (notePrefix h <+> replaceLinesWith prefix 7 (annotated $ noteMessage h))
<> prettyAllHints hs leftLen withUnicode <> prettyAllHints hs leftLen withUnicode
where where
notePrefix (Note _) = "Note:" notePrefix (Note _) = "Note:"
@ -704,3 +715,11 @@ safeArrayIndex :: (Ix i, IArray a e) => i -> a i e -> Maybe e
safeArrayIndex i a safeArrayIndex i a
| Array.inRange (Array.bounds a) i = Just (a ! i) | Array.inRange (Array.bounds a) i = Just (a ! i)
| otherwise = Nothing | otherwise = Nothing
annotated :: Doc ann -> Doc (Annotation ann)
annotated = reAnnotate OtherStyle
unicode :: a -> a -> WithUnicode -> a
unicode f t = \case
WithoutUnicode -> f
WithUnicode -> t

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

@ -1,3 +1,5 @@
{-# LANGUAGE DeriveTraversable #-}
-- | -- |
-- Module : Error.Diagnose.Style -- Module : Error.Diagnose.Style
-- Description : Custom style definitions -- Description : Custom style definitions
@ -11,15 +13,12 @@ module Error.Diagnose.Style
Style, Style,
-- $defining_new_styles -- $defining_new_styles
-- * Default style specification -- * Styles
defaultStyle, defaultStyle,
unadornedStyle,
-- * Re-exports
reAnnotate,
) )
where where
import Prettyprinter (Doc, reAnnotate)
import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), bold, color, colorDull) import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), bold, color, colorDull)
-- $defining_new_styles -- $defining_new_styles
@ -41,7 +40,7 @@ import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), bold, color, colorD
-- For simplicity's sake, a default style is given as 'defaultStyle'. -- For simplicity's sake, a default style is given as 'defaultStyle'.
-- | Some annotations as placeholders for colors in a 'Doc'. -- | Some annotations as placeholders for colors in a 'Doc'.
data Annotation data Annotation a
= -- | The color of 'Error.Diagnose.Report.This' markers, depending on whether the report is an error = -- | The color of 'Error.Diagnose.Report.This' markers, depending on whether the report is an error
-- report or a warning report. -- report or a warning report.
ThisColor ThisColor
@ -67,18 +66,25 @@ data Annotation
| -- | Additional style to apply to marker rules (e.g. bold) on top of some | -- | Additional style to apply to marker rules (e.g. bold) on top of some
-- already processed color annotation. -- already processed color annotation.
MarkerStyle MarkerStyle
Annotation (Annotation a)
| -- | The color of the code when no marker is present. | -- | The color of the code when no marker is present.
CodeStyle CodeStyle
| -- | Something else, could be provided by the user
OtherStyle a
deriving (Functor, Foldable, Traversable)
-- | A style is a function which can be applied using 'reAnnotate'. -- | A style is a function which can be applied using 'reAnnotate'.
-- --
-- It transforms a 'Doc'ument containing 'Annotation's into a 'Doc'ument containing -- It transforms a 'Doc'ument containing 'Annotation's into a 'Doc'ument containing
-- color information. -- color information.
type Style = Doc Annotation -> Doc AnsiStyle type Style a = Annotation a -> AnsiStyle
------------------------------------------- -------------------------------------------
-- | A style which disregards all annotations
unadornedStyle :: Style a
unadornedStyle = const mempty
-- | The default style for diagnostics, where: -- | The default style for diagnostics, where:
-- --
-- * 'Error.Diagnose.Report.This' markers are colored in red for errors and yellow for warnings -- * 'Error.Diagnose.Report.This' markers are colored in red for errors and yellow for warnings
@ -90,21 +96,20 @@ type Style = Doc Annotation -> Doc AnsiStyle
-- * File names are output in dull green -- * File names are output in dull green
-- * The @[error]@/@[warning]@ at the top is colored in red for errors and yellow for warnings -- * The @[error]@/@[warning]@ at the top is colored in red for errors and yellow for warnings
-- * The code is output in normal white -- * The code is output in normal white
defaultStyle :: Style defaultStyle :: Style AnsiStyle
defaultStyle = reAnnotate style defaultStyle = \case
where
style = \case
ThisColor isError -> color if isError then Red else Yellow ThisColor isError -> color if isError then Red else Yellow
MaybeColor -> color Magenta MaybeColor -> color Magenta
WhereColor -> colorDull Blue WhereColor -> colorDull Blue
HintColor -> color Cyan HintColor -> color Cyan
FileColor -> bold <> colorDull Green FileColor -> bold <> colorDull Green
RuleColor -> bold <> color Black RuleColor -> bold <> color Black
KindColor isError -> bold <> style (ThisColor isError) KindColor isError -> bold <> defaultStyle (ThisColor isError)
NoLineColor -> bold <> colorDull Magenta NoLineColor -> bold <> colorDull Magenta
MarkerStyle st -> MarkerStyle st ->
let ann = style st let ann = defaultStyle st
in if ann == style CodeStyle in if ann == defaultStyle CodeStyle
then ann then ann
else bold <> ann else bold <> ann
CodeStyle -> color White CodeStyle -> color White
OtherStyle s -> s

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

9
test/megaparsec/Spec.hs
View File

@ -16,7 +16,6 @@ import Error.Diagnose.Compat.Megaparsec
import Instances () import Instances ()
import qualified Repro6 import qualified Repro6
import qualified Text.Megaparsec as MP import qualified Text.Megaparsec as MP
import qualified Text.Megaparsec.Char as MP
import qualified Text.Megaparsec.Char.Lexer as MP import qualified Text.Megaparsec.Char.Lexer as MP
main :: IO () main :: IO ()
@ -29,11 +28,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 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 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 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 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

7
test/parsec/Spec.hs
View File

@ -3,7 +3,6 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS -Wno-orphans #-} {-# OPTIONS -Wno-orphans #-}
@ -32,13 +31,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 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 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 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

117
test/rendering/Spec.hs
View File

@ -1,14 +1,17 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
#ifdef USE_AESON #ifdef USE_AESON
import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as BS
import Error.Diagnose(diagnosticToJson)
#endif #endif
import Data.HashMap.Lazy (HashMap) import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HashMap import qualified Data.HashMap.Lazy as HashMap
import Error.Diagnose import Error.Diagnose
( Marker (..), ( Marker (..),
Note (Hint), Note (..),
Position (..), Position (..),
Report(..), Report(..),
addFile, addFile,
@ -16,9 +19,17 @@ import Error.Diagnose
def, def,
defaultStyle, defaultStyle,
printDiagnostic, printDiagnostic,
printDiagnostic',
stdout, stdout,
WithUnicode (..),
TabSize (..),
) )
import System.IO (hPutStrLn) import System.IO (hPutStrLn)
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(..))
main :: IO () main :: IO ()
main = do main = do
@ -73,19 +84,119 @@ main = do
errorWithBlankAndNormalMarkerInLine, errorWithBlankAndNormalMarkerInLine,
beautifulExample beautifulExample
] ]
customAnnReports =
[ colorfulReport,
indentedReport,
nestingReport
]
let diag = HashMap.foldlWithKey' addFile (foldl addReport def reports) files let diag = HashMap.foldlWithKey' addFile (foldl addReport def reports) files
customDiag = HashMap.foldlWithKey' addFile (foldl addReport def customAnnReports) files
hPutStrLn stdout "\n\nWith unicode: ─────────────────────────\n" hPutStrLn stdout "\n\nWith unicode: ─────────────────────────\n"
printDiagnostic stdout True 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 True 4 defaultStyle diag printDiagnostic stdout WithoutUnicode (TabSize 4) defaultStyle diag
hPutStrLn stdout "\n\nWith custom annotations: ----------------------\n"
printDiagnostic' stdout WithUnicode (TabSize 4) defaultStyle customDiag
#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)
#endif #endif
hPutStrLn stdout "\n" hPutStrLn stdout "\n"
colorfulReport :: Report (Doc AnsiStyle)
colorfulReport =
fmap hsep
. getCompose
. snd
. mapAccumL
(\(c : cs) s -> (cs, annotate c (pretty s)))
styles
. Compose
. fmap words
$ realWorldExample
where
styles = [ color fg <> e
| fg <- cycle [Black, Red, Green, Yellow, Blue, Magenta, Cyan, White]
| e <- cycle [bold, italicized, underlined]
]
indentedReport :: Report (Doc AnsiStyle)
indentedReport =
Err
Nothing
("Indent..." <> indent 3 (vsep ["foo", "bar", "baz"]))
[ (Position (1, 15) (1, 16) "test.zc", Maybe a)
, (Position (1, 11) (1, 12) "test.zc", This b)
]
[Note c]
where
a =
vsep
[ "A woman’s face with Nature’s own hand painted"
, "Hast thou, the master-mistress of my passion;"
, "A woman’s gentle heart, but not acquainted"
, "With shifting change, as is false women’s fashion;"
]
b =
vsep
[ "An eye more bright than theirs, less false in rolling,"
, "Gilding the object whereupon it gazeth;"
, "A man in hue, all “hues” in his controlling,"
, "Which steals men’s eyes and women’s souls amazeth."
]
c =
vsep
[ "And for a woman wert thou first created;"
, "Till Nature, as she wrought thee, fell a-doting,"
, "And by addition me of thee defeated,"
, "By adding one thing to my purpose nothing."
, indent 4 "But since she prick’d thee out for women’s pleasure,"
, indent 4 "Mine be thy love and thy love’s use their treasure."
]
nestingReport :: Report (Doc AnsiStyle)
nestingReport =
Err
Nothing
(nest 4 $ vsep ["Nest...", "foo", "bar", "baz"])
[ (Position (1, 15) (1, 16) "test.zc", Maybe a)
]
[Note b, Hint c]
where
a =
nest 3 $
vsep
[ "'What day is it?' asked Pooh."
, "'It's today,' squeaked Piglet."
, "'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."
]
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 :: Report String
errorNoMarkersNoHints = errorNoMarkersNoHints =
Err Err