mirror of
https://github.com/Mesabloo/diagnose.git
synced 2024-09-11 19:27:32 +03:00
correctly output reports with multiple files
This commit is contained in:
parent
26f5639dc5
commit
79020a3b30
@ -1,32 +1,31 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
{-# OPTIONS -Wno-name-shadowing #-}
|
||||
|
||||
{-|
|
||||
Module : Error.Diagnose.Report.Internal
|
||||
Description : Internal workings for report definitions and pretty printing.
|
||||
Copyright : (c) Mesabloo, 2021
|
||||
License : BSD3
|
||||
Stability : experimental
|
||||
Portability : Portable
|
||||
|
||||
/Warning/: The API of this module can break between two releases, therefore you should not rely on it.
|
||||
It is also highly undocumented.
|
||||
|
||||
Please limit yourself to the "Error.Diagnose.Report" module, which exports some of the useful functions defined here.
|
||||
-}
|
||||
-- |
|
||||
-- Module : Error.Diagnose.Report.Internal
|
||||
-- Description : Internal workings for report definitions and pretty printing.
|
||||
-- Copyright : (c) Mesabloo, 2021
|
||||
-- License : BSD3
|
||||
-- Stability : experimental
|
||||
-- Portability : Portable
|
||||
--
|
||||
-- /Warning/: The API of this module can break between two releases, therefore you should not rely on it.
|
||||
-- It is also highly undocumented.
|
||||
--
|
||||
-- Please limit yourself to the "Error.Diagnose.Report" module, which exports some of the useful functions defined here.
|
||||
module Error.Diagnose.Report.Internal where
|
||||
|
||||
#ifdef USE_AESON
|
||||
import Data.Aeson (ToJSON(..), object, (.=))
|
||||
#endif
|
||||
import Data.Bifunctor (first, second, bimap)
|
||||
import Data.Bifunctor (bimap, first, second)
|
||||
import Data.Default (def)
|
||||
import Data.Foldable (fold)
|
||||
import Data.Function (on)
|
||||
@ -35,22 +34,23 @@ import Data.HashMap.Lazy (HashMap)
|
||||
import qualified Data.HashMap.Lazy as HashMap
|
||||
import qualified Data.List as List
|
||||
import qualified Data.List.Safe as List
|
||||
import Data.Ord (Down(..))
|
||||
|
||||
import Data.Ord (Down (..))
|
||||
import Error.Diagnose.Position
|
||||
|
||||
import Prettyprinter (Pretty(..), Doc, hardline, (<+>), align, space, annotate, width, colon)
|
||||
import Prettyprinter.Internal (Doc(..))
|
||||
import Prettyprinter.Render.Terminal (color, colorDull, Color(..), bold, AnsiStyle)
|
||||
|
||||
import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, space, width, (<+>))
|
||||
import Prettyprinter.Internal (Doc (..))
|
||||
import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), bold, color, colorDull)
|
||||
|
||||
-- | The type of diagnostic reports with abstract message type.
|
||||
data Report msg
|
||||
= Report
|
||||
Bool -- ^ Is the report a warning or an error?
|
||||
msg -- ^ The message associated with the error.
|
||||
[(Position, Marker msg)] -- ^ A map associating positions with marker to show under the source code.
|
||||
[msg] -- ^ A list of hints to add at the end of the report.
|
||||
Bool
|
||||
-- ^ Is the report a warning or an error?
|
||||
msg
|
||||
-- ^ The message associated with the error.
|
||||
[(Position, Marker msg)]
|
||||
-- ^ A map associating positions with marker to show under the source code.
|
||||
[msg]
|
||||
-- ^ A list of hints to add at the end of the report.
|
||||
|
||||
instance Semigroup msg => Semigroup (Report msg) where
|
||||
Report isError1 msg1 pos1 hints1 <> Report isError2 msg2 pos2 hints2 =
|
||||
@ -92,79 +92,78 @@ data Marker msg
|
||||
Maybe msg
|
||||
|
||||
instance Eq (Marker msg) where
|
||||
This _ == This _ = True
|
||||
This _ == This _ = True
|
||||
Where _ == Where _ = True
|
||||
Maybe _ == Maybe _ = True
|
||||
_ == _ = False
|
||||
{-# INLINABLE (==) #-}
|
||||
_ == _ = False
|
||||
{-# INLINEABLE (==) #-}
|
||||
|
||||
instance Ord (Marker msg) where
|
||||
This _ < _ = False
|
||||
This _ < _ = False
|
||||
Where _ < This _ = True
|
||||
Where _ < _ = False
|
||||
Maybe _ < _ = True
|
||||
{-# INLINABLE (<) #-}
|
||||
|
||||
m1 <= m2 = m1 < m2 || m1 == m2
|
||||
{-# INLINABLE (<=) #-}
|
||||
Where _ < _ = False
|
||||
Maybe _ < _ = True
|
||||
{-# INLINEABLE (<) #-}
|
||||
|
||||
m1 <= m2 = m1 < m2 || m1 == m2
|
||||
{-# INLINEABLE (<=) #-}
|
||||
|
||||
-- | Constructs a warning or an error report.
|
||||
warn, err :: msg -- ^ The report message, shown at the very top.
|
||||
-> [(Position, Marker msg)] -- ^ A list associating positions with markers.
|
||||
-> [msg] -- ^ A possibly mempty list of hints to add at the end of the report.
|
||||
-> Report msg
|
||||
warn,
|
||||
err ::
|
||||
-- | The report message, shown at the very top.
|
||||
msg ->
|
||||
-- | A list associating positions with markers.
|
||||
[(Position, Marker msg)] ->
|
||||
-- | A possibly mempty list of hints to add at the end of the report.
|
||||
[msg] ->
|
||||
Report msg
|
||||
warn = Report False
|
||||
{-# INLINE warn #-}
|
||||
err = Report True
|
||||
{-# INLINE err #-}
|
||||
|
||||
-- | Pretty prints a report to a 'Doc' handling colors.
|
||||
prettyReport :: Pretty msg
|
||||
=> HashMap FilePath [String] -- ^ The content of the file the reports are for
|
||||
-> Bool -- ^ Should we print paths in unicode?
|
||||
-> Report msg -- ^ The whole report to output
|
||||
-> Doc AnsiStyle
|
||||
prettyReport ::
|
||||
Pretty msg =>
|
||||
-- | The content of the file the reports are for
|
||||
HashMap FilePath [String] ->
|
||||
-- | Should we print paths in unicode?
|
||||
Bool ->
|
||||
-- | The whole report to output
|
||||
Report msg ->
|
||||
Doc AnsiStyle
|
||||
prettyReport fileContent withUnicode (Report isError message markers hints) =
|
||||
let sortedMarkers = List.sortOn (fst . begin . fst) markers
|
||||
-- sort the markers so that the first lines of the reports are the first lines of the file
|
||||
|
||||
(markersPerLine, multilineMarkers) = splitMarkersPerLine sortedMarkers
|
||||
-- split the list on whether markers are multiline or not
|
||||
groupedMarkers = groupMarkersPerFile sortedMarkers
|
||||
-- group markers by the file they appear in, and put `This` markers at the top of the report
|
||||
|
||||
sortedMarkersPerLine = {- second (List.sortOn (first $ snd . begin)) <$> -} List.sortOn fst (HashMap.toList markersPerLine)
|
||||
|
||||
reportFile = maybe (pretty @Position def) (pretty . fst) $ List.safeHead (filter (isThisMarker . snd) sortedMarkers)
|
||||
-- the reported file is the file of the first 'This' marker (only one must be present)
|
||||
|
||||
header = annotate bold if isError then annotate (color Red) "[error]" else annotate (color Yellow) "[warning]"
|
||||
|
||||
maxLineNumberLength = maybe 3 (max 3 . length . show . fst . end . fst) $ List.safeLast sortedMarkers
|
||||
maxLineNumberLength = maybe 3 (max 3 . length . show . fst . end . fst) $ List.safeLast markers
|
||||
-- if there are no markers, then default to 3, else get the maximum between 3 and the length of the last marker
|
||||
|
||||
allLineNumbers = List.sort $ List.nub $ (fst <$> sortedMarkersPerLine) <> (multilineMarkers >>= \ (Position (bl, _) (el, _) _, _) -> [bl..el])
|
||||
{-
|
||||
A report is of the form:
|
||||
(1) [error|warning]: <message>
|
||||
(2) +-> <file>
|
||||
(3) :
|
||||
(4) <line> | <line of code>
|
||||
: <marker lines>
|
||||
: <marker messages>
|
||||
(5) :
|
||||
: <hints>
|
||||
(6) -------+
|
||||
-}
|
||||
in {- (1) -} header <> colon <+> align (pretty message) <> hardline
|
||||
<+> {- (2) -} pad maxLineNumberLength ' ' mempty <+> annotate (bold <> color Black) (if withUnicode then "╭─▶" else "+->") <+> annotate (bold <> colorDull Green) reportFile <> hardline
|
||||
<+> {- (3) -} pipePrefix maxLineNumberLength withUnicode
|
||||
<> {- (4) -} prettyAllLines fileContent withUnicode isError maxLineNumberLength sortedMarkersPerLine multilineMarkers allLineNumbers
|
||||
<> {- (5) -} (if null hints || null markers then mempty else hardline <+> dotPrefix maxLineNumberLength withUnicode) <> prettyAllHints hints maxLineNumberLength withUnicode <> hardline
|
||||
<> {- (6) -} annotate (bold <> color Black) (pad (maxLineNumberLength + 2) (if withUnicode then '─' else '-') mempty <> if withUnicode then "╯" else "+") <> hardline
|
||||
where
|
||||
isThisMarker (This _) = True
|
||||
isThisMarker _ = False
|
||||
header = annotate bold if isError then annotate (color Red) "[error]" else annotate (color Yellow) "[warning]"
|
||||
in {-
|
||||
A report is of the form:
|
||||
(1) [error|warning]: <message>
|
||||
(2) +-> <file>
|
||||
(3) :
|
||||
(4) <line> | <line of code>
|
||||
: <marker lines>
|
||||
: <marker messages>
|
||||
(5) :
|
||||
: <hints>
|
||||
(6) -------+
|
||||
-}
|
||||
|
||||
{- (1) -} header <> colon <+> align (pretty message)
|
||||
<> {- (2), (3), (4) -} fold (uncurry (prettySubReport fileContent withUnicode isError maxLineNumberLength) <$> groupedMarkers)
|
||||
<> {- (5) -} (if null hints || null markers then mempty else hardline <+> dotPrefix maxLineNumberLength withUnicode)
|
||||
<> prettyAllHints hints maxLineNumberLength withUnicode
|
||||
<> hardline
|
||||
<> {- (6) -} annotate (bold <> color Black) (pad (maxLineNumberLength + 2) (if withUnicode then '─' else '-') mempty <> if withUnicode then "╯" else "+")
|
||||
<> hardline
|
||||
|
||||
-------------------------------------------------------------------------------------
|
||||
----- INTERNAL STUFF ----------------------------------------------------------------
|
||||
@ -172,7 +171,7 @@ prettyReport fileContent withUnicode (Report isError message markers hints) =
|
||||
|
||||
-- | Inserts a given number of character after a 'Doc'ument.
|
||||
pad :: Int -> Char -> Doc ann -> Doc ann
|
||||
pad n c d = width d \ w -> pretty $ replicate (n - w) c
|
||||
pad n c d = width d \w -> pretty $ replicate (n - w) c
|
||||
|
||||
-- | Creates a "dot"-prefix for a report line where there is no code.
|
||||
--
|
||||
@ -180,9 +179,12 @@ pad n c d = width d \ w -> pretty $ replicate (n - w) c
|
||||
--
|
||||
-- [with unicode] "@␣␣␣␣␣•␣@"
|
||||
-- [without unicode] "@␣␣␣␣␣:␣@"
|
||||
dotPrefix :: Int -- ^ The length of the left space before the bullet.
|
||||
-> Bool -- ^ Whether to print with unicode characters or not.
|
||||
-> Doc AnsiStyle
|
||||
dotPrefix ::
|
||||
-- | The length of the left space before the bullet.
|
||||
Int ->
|
||||
-- | Whether to print with unicode characters or not.
|
||||
Bool ->
|
||||
Doc AnsiStyle
|
||||
dotPrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate (bold <> color Black) (if withUnicode then "•" else ":")
|
||||
{-# INLINE dotPrefix #-}
|
||||
|
||||
@ -192,9 +194,12 @@ dotPrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate (bold <> col
|
||||
--
|
||||
-- [with unicode] "@␣␣␣␣␣│␣@"
|
||||
-- [without unicode] "@␣␣␣␣␣|␣@"
|
||||
pipePrefix :: Int -- ^ The length of the left space before the pipe.
|
||||
-> Bool -- ^ Whether to print with unicode characters or not.
|
||||
-> Doc AnsiStyle
|
||||
pipePrefix ::
|
||||
-- | The length of the left space before the pipe.
|
||||
Int ->
|
||||
-- | Whether to print with unicode characters or not.
|
||||
Bool ->
|
||||
Doc AnsiStyle
|
||||
pipePrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate (bold <> color Black) (if withUnicode then "│" else "|")
|
||||
{-# INLINE pipePrefix #-}
|
||||
|
||||
@ -206,234 +211,325 @@ pipePrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate (bold <> co
|
||||
-- [without unicode] "@␣␣␣3␣|␣@"
|
||||
--
|
||||
-- Results may be different, depending on the length of the line number.
|
||||
linePrefix :: Int -- ^ The length of the amount of space to span before the vertical bar.
|
||||
-> Int -- ^ The line number to show.
|
||||
-> Bool -- ^ Whether to use unicode characters or not.
|
||||
-> Doc AnsiStyle
|
||||
linePrefix ::
|
||||
-- | The length of the amount of space to span before the vertical bar.
|
||||
Int ->
|
||||
-- | The line number to show.
|
||||
Int ->
|
||||
-- | Whether to use unicode characters or not.
|
||||
Bool ->
|
||||
Doc AnsiStyle
|
||||
linePrefix leftLen lineNo withUnicode =
|
||||
let lineNoLen = length (show lineNo)
|
||||
in annotate (bold <> color Black) $ mempty <+> pad (leftLen - lineNoLen) ' ' mempty <> pretty lineNo <+> if withUnicode then "│" else "|"
|
||||
in annotate (bold <> color Black) $ mempty <+> pad (leftLen - lineNoLen) ' ' mempty <> pretty lineNo <+> if withUnicode then "│" else "|"
|
||||
{-# INLINE linePrefix #-}
|
||||
|
||||
groupMarkersPerFile ::
|
||||
Pretty msg =>
|
||||
[(Position, Marker msg)] ->
|
||||
[(Bool, [(Position, Marker msg)])]
|
||||
groupMarkersPerFile [] = []
|
||||
groupMarkersPerFile markers =
|
||||
let markersPerFile = List.foldl' (HashMap.unionWith (<>)) mempty $ markers <&> \tup@(p, _) -> HashMap.singleton (file p) [tup]
|
||||
in -- put all markers on the same file together
|
||||
-- NOTE: it's a shame that `HashMap.unionsWith f = foldl' (HashMap.unionWith f) mempty` does not exist
|
||||
|
||||
onlyFirstToTrue $ putThisMarkersAtTop $ HashMap.elems markersPerFile
|
||||
where
|
||||
onlyFirstToTrue = go True []
|
||||
|
||||
go _ acc [] = reverse acc
|
||||
go t acc (x : xs) = go False ((t, x) : acc) xs
|
||||
|
||||
putThisMarkersAtTop = List.sortBy \ms1 ms2 ->
|
||||
if
|
||||
| any isThisMarker (snd <$> ms1) -> LT
|
||||
| any isThisMarker (snd <$> ms2) -> GT
|
||||
| otherwise -> EQ
|
||||
|
||||
-- | Prettyprint a sub-report, which is a part of the report spanning across a single file
|
||||
prettySubReport ::
|
||||
Pretty msg =>
|
||||
-- | The content of files in the diagnostics
|
||||
HashMap FilePath [String] ->
|
||||
-- | Is the output done with Unicode characters?
|
||||
Bool ->
|
||||
-- | Is the current report an error report?
|
||||
Bool ->
|
||||
-- | The size of the biggest line number
|
||||
Int ->
|
||||
-- | Is this sub-report the first one in the list?
|
||||
Bool ->
|
||||
-- | The list of line-ordered markers appearing in a single file
|
||||
[(Position, Marker msg)] ->
|
||||
Doc AnsiStyle
|
||||
prettySubReport fileContent withUnicode isError maxLineNumberLength isFirst markers =
|
||||
let (markersPerLine, multilineMarkers) = splitMarkersPerLine markers
|
||||
-- split the list on whether markers are multiline or not
|
||||
|
||||
sortedMarkersPerLine = {- second (List.sortOn (first $ snd . begin)) <$> -} List.sortOn fst (HashMap.toList markersPerLine)
|
||||
|
||||
reportFile = maybe (pretty @Position def) (pretty . fst) $ List.safeHead (List.sortOn snd markers)
|
||||
-- the reported file is the file of the first 'This' marker (only one must be present)
|
||||
|
||||
allLineNumbers = List.sort $ List.nub $ (fst <$> sortedMarkersPerLine) <> (multilineMarkers >>= \(Position (bl, _) (el, _) _, _) -> [bl .. el])
|
||||
|
||||
fileMarker =
|
||||
( if isFirst
|
||||
then
|
||||
space <> pad maxLineNumberLength ' ' mempty
|
||||
<+> annotate (bold <> color Black) (if withUnicode then "╭──▶" else "+-->")
|
||||
else
|
||||
space <> dotPrefix maxLineNumberLength withUnicode <> hardline
|
||||
<> annotate (bold <> color Black) (pad (maxLineNumberLength + 2) (if withUnicode then '─' else '-') mempty)
|
||||
<> annotate (bold <> color Black) (if withUnicode then "┼──▶" else "+-->")
|
||||
)
|
||||
<+> annotate (bold <> colorDull Green) reportFile
|
||||
in {- (2) -} hardline <> fileMarker
|
||||
<> hardline
|
||||
<+> {- (3) -} pipePrefix maxLineNumberLength withUnicode
|
||||
<> {- (4) -} prettyAllLines fileContent withUnicode isError maxLineNumberLength sortedMarkersPerLine multilineMarkers allLineNumbers
|
||||
|
||||
isThisMarker :: Marker msg -> Bool
|
||||
isThisMarker (This _) = True
|
||||
isThisMarker _ = False
|
||||
|
||||
-- |
|
||||
splitMarkersPerLine :: [(Position, Marker msg)] -> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
|
||||
splitMarkersPerLine [] = (mempty, mempty)
|
||||
splitMarkersPerLine (m@(Position{..}, _) : ms) =
|
||||
splitMarkersPerLine [] = (mempty, mempty)
|
||||
splitMarkersPerLine (m@(Position {..}, _) : ms) =
|
||||
let (bl, _) = begin
|
||||
(el, _) = end
|
||||
in (if bl == el then first (HashMap.insertWith (<>) bl [m]) else second (m :))
|
||||
in (if bl == el then first (HashMap.insertWith (<>) bl [m]) else second (m :))
|
||||
(splitMarkersPerLine ms)
|
||||
|
||||
-- |
|
||||
prettyAllLines :: Pretty msg
|
||||
=> HashMap FilePath [String]
|
||||
-> Bool
|
||||
-> Bool
|
||||
-> Int
|
||||
-> [(Int, [(Position, Marker msg)])]
|
||||
-> [(Position, Marker msg)]
|
||||
-> [Int]
|
||||
-> Doc AnsiStyle
|
||||
prettyAllLines _ _ _ _ _ [] [] = mempty
|
||||
prettyAllLines _ withUnicode isError leftLen _ multiline [] =
|
||||
prettyAllLines ::
|
||||
Pretty msg =>
|
||||
HashMap FilePath [String] ->
|
||||
Bool ->
|
||||
Bool ->
|
||||
Int ->
|
||||
[(Int, [(Position, Marker msg)])] ->
|
||||
[(Position, Marker msg)] ->
|
||||
[Int] ->
|
||||
Doc AnsiStyle
|
||||
prettyAllLines _ _ _ _ _ [] [] = mempty
|
||||
prettyAllLines _ withUnicode isError leftLen _ multiline [] =
|
||||
let colorOfLastMultilineMarker = maybe mempty (markerColor isError . snd) (List.safeLast multiline)
|
||||
-- take the color of the last multiline marker in case we need to add additional bars
|
||||
|
||||
prefix = hardline <+> dotPrefix leftLen withUnicode <> space
|
||||
prefixWithBar color = prefix <> annotate color (if withUnicode then "│ " else "| ")
|
||||
|
||||
showMultilineMarkerMessage (_, marker) isLast = annotate (markerColor isError marker) $ (if isLast
|
||||
then if withUnicode then "╰╸ " else "`- "
|
||||
else if withUnicode then "├╸ " else "|- ")
|
||||
<> replaceLinesWith (if isLast then prefix <> " " else prefixWithBar (markerColor isError marker) <> space) (pretty $ markerMessage marker)
|
||||
showMultilineMarkerMessage (_, marker) isLast =
|
||||
annotate (markerColor isError marker) $
|
||||
( if isLast
|
||||
then if withUnicode then "╰╸ " else "`- "
|
||||
else if withUnicode then "├╸ " else "|- "
|
||||
)
|
||||
<> replaceLinesWith (if isLast then prefix <> " " else prefixWithBar (markerColor isError marker) <> space) (pretty $ markerMessage marker)
|
||||
|
||||
showMultilineMarkerMessages [] = []
|
||||
showMultilineMarkerMessages [m] = [showMultilineMarkerMessage m True]
|
||||
showMultilineMarkerMessages [] = []
|
||||
showMultilineMarkerMessages [m] = [showMultilineMarkerMessage m True]
|
||||
showMultilineMarkerMessages (m : ms) = showMultilineMarkerMessage m False : showMultilineMarkerMessages ms
|
||||
|
||||
in prefixWithBar colorOfLastMultilineMarker <> prefix <> fold (List.intersperse prefix $ showMultilineMarkerMessages $ reverse multiline)
|
||||
in prefixWithBar colorOfLastMultilineMarker <> prefix <> fold (List.intersperse prefix $ showMultilineMarkerMessages $ reverse multiline)
|
||||
prettyAllLines files withUnicode isError leftLen inline multiline (line : ls) =
|
||||
{-
|
||||
A line of code is composed of:
|
||||
(1) <line> | <source code>
|
||||
(2) : <markers>
|
||||
(3) : <marker messages>
|
||||
{-
|
||||
A line of code is composed of:
|
||||
(1) <line> | <source code>
|
||||
(2) : <markers>
|
||||
(3) : <marker messages>
|
||||
|
||||
|
||||
Multline markers may also take additional space (2 characters) on the right of the bar
|
||||
-}
|
||||
Multline markers may also take additional space (2 characters) on the right of the bar
|
||||
-}
|
||||
let allInlineMarkersInLine = snd =<< filter ((==) line . fst) inline
|
||||
|
||||
allMultilineMarkersInLine = flip filter multiline \ (Position (bl, _) (el, _) _, _) -> bl == line || el == line
|
||||
allMultilineMarkersInLine = flip filter multiline \(Position (bl, _) (el, _) _, _) -> bl == line || el == line
|
||||
|
||||
allMultilineMarkersSpanningLine = flip filter multiline \ (Position (bl, _) (el, _) _, _) -> bl < line && el > line
|
||||
allMultilineMarkersSpanningLine = flip filter multiline \(Position (bl, _) (el, _) _, _) -> bl < line && el > line
|
||||
|
||||
inSpanOfMultiline = flip any multiline \ (Position (bl, _) (el, _) _, _) -> bl <= line && el >= line
|
||||
inSpanOfMultiline = flip any multiline \(Position (bl, _) (el, _) _, _) -> bl <= line && el >= line
|
||||
|
||||
colorOfFirstMultilineMarker = maybe id (annotate . markerColor isError . snd) (List.safeHead $ allMultilineMarkersInLine <> allMultilineMarkersSpanningLine)
|
||||
-- take the first multiline marker to color the entire line, if there is one
|
||||
|
||||
!additionalPrefix = case allMultilineMarkersInLine of
|
||||
[] ->
|
||||
[] ->
|
||||
if not $ null multiline
|
||||
then if not $ null allMultilineMarkersSpanningLine
|
||||
then colorOfFirstMultilineMarker if withUnicode then "│ " else "| "
|
||||
else " "
|
||||
else mempty
|
||||
then
|
||||
if not $ null allMultilineMarkersSpanningLine
|
||||
then colorOfFirstMultilineMarker if withUnicode then "│ " else "| "
|
||||
else " "
|
||||
else mempty
|
||||
(p@(Position _ (el, _) _), marker) : _ ->
|
||||
let hasPredecessor = el == line || maybe False ((/=) p . fst . fst) (List.safeUncons multiline)
|
||||
in colorOfFirstMultilineMarker (if | hasPredecessor && withUnicode -> "├"
|
||||
| hasPredecessor -> "|"
|
||||
| withUnicode -> "╭"
|
||||
| otherwise -> "+")
|
||||
<> annotate (markerColor isError marker) (if withUnicode then "┤" else ">")
|
||||
<> space
|
||||
in colorOfFirstMultilineMarker
|
||||
( if
|
||||
| hasPredecessor && withUnicode -> "├"
|
||||
| hasPredecessor -> "|"
|
||||
| withUnicode -> "╭"
|
||||
| otherwise -> "+"
|
||||
)
|
||||
<> annotate (markerColor isError marker) (if withUnicode then "┤" else ">")
|
||||
<> space
|
||||
|
||||
allMarkersInLine = {- List.sortOn fst $ -} allInlineMarkersInLine <> allMultilineMarkersInLine
|
||||
in hardline
|
||||
<> {- (1) -} linePrefix leftLen line withUnicode <+> additionalPrefix <> getLine_ files (allMarkersInLine <> allMultilineMarkersSpanningLine) line isError
|
||||
<> {- (2) -} showAllMarkersInLine (not $ null multiline) inSpanOfMultiline colorOfFirstMultilineMarker withUnicode isError leftLen allInlineMarkersInLine
|
||||
<> {- (3) -} prettyAllLines files withUnicode isError leftLen inline multiline ls
|
||||
in hardline
|
||||
<> {- (1) -} linePrefix leftLen line withUnicode <+> additionalPrefix
|
||||
<> getLine_ files (allMarkersInLine <> allMultilineMarkersSpanningLine) line isError
|
||||
<> {- (2) -} showAllMarkersInLine (not $ null multiline) inSpanOfMultiline colorOfFirstMultilineMarker withUnicode isError leftLen allInlineMarkersInLine
|
||||
<> {- (3) -} prettyAllLines files withUnicode isError leftLen inline multiline ls
|
||||
|
||||
-- |
|
||||
getLine_ :: HashMap FilePath [String] -> [(Position, Marker msg)] -> Int -> Bool -> Doc AnsiStyle
|
||||
getLine_ files markers line isError = case List.safeIndex (line - 1) =<< (HashMap.!?) files . file . fst =<< List.safeHead markers of
|
||||
Nothing -> annotate (bold <> colorDull Magenta) "<no line>"
|
||||
Just code -> fold $ indexed code <&> \ (n, c) ->
|
||||
let colorizingMarkers = flip filter markers
|
||||
\ (Position (bl, bc) (el, ec) _, _) ->
|
||||
if bl == el
|
||||
then n >= bc && n < ec
|
||||
else (bl == line && n >= bc) || (el == line && n < ec)
|
||||
|
||||
in maybe id ((\ m -> annotate (bold <> markerColor isError m)) . snd) (List.safeHead colorizingMarkers) (pretty c)
|
||||
Nothing -> annotate (bold <> colorDull Magenta) "<no line>"
|
||||
Just code ->
|
||||
fold $
|
||||
indexed code <&> \(n, c) ->
|
||||
let colorizingMarkers = flip
|
||||
filter
|
||||
markers
|
||||
\(Position (bl, bc) (el, ec) _, _) ->
|
||||
if bl == el
|
||||
then n >= bc && n < ec
|
||||
else (bl == line && n >= bc) || (el == line && n < ec)
|
||||
in maybe id ((\m -> annotate (bold <> markerColor isError m)) . snd) (List.safeHead colorizingMarkers) (pretty c)
|
||||
where
|
||||
indexed :: [a] -> [(Int, a)]
|
||||
indexed = goIndexed 1
|
||||
|
||||
goIndexed :: Int -> [a] -> [(Int, a)]
|
||||
goIndexed _ [] = []
|
||||
goIndexed _ [] = []
|
||||
goIndexed n (x : xs) = (n, x) : goIndexed (n + 1) xs
|
||||
|
||||
-- |
|
||||
showAllMarkersInLine :: Pretty msg => Bool -> Bool -> (Doc AnsiStyle -> Doc AnsiStyle) -> Bool -> Bool -> Int -> [(Position, Marker msg)] -> Doc AnsiStyle
|
||||
showAllMarkersInLine _ _ _ _ _ _ [] = mempty
|
||||
showAllMarkersInLine _ _ _ _ _ _ [] = mempty
|
||||
showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUnicode isError leftLen ms =
|
||||
let maxMarkerColumn = snd $ end $ fst $ List.last $ List.sortOn (snd . end . fst) ms
|
||||
specialPrefix = if inSpanOfMultiline
|
||||
then colorMultilinePrefix (if withUnicode then "│ " else "| ") <> space
|
||||
else if hasMultilines
|
||||
then colorMultilinePrefix " " <> space
|
||||
else mempty
|
||||
-- get the maximum end column, so that we know when to stop looking for other markers on the same line
|
||||
in hardline <+> dotPrefix leftLen withUnicode <+> (if List.null ms then mempty else specialPrefix <> showMarkers 1 maxMarkerColumn <> showMessages specialPrefix ms maxMarkerColumn)
|
||||
specialPrefix =
|
||||
if inSpanOfMultiline
|
||||
then colorMultilinePrefix (if withUnicode then "│ " else "| ") <> space
|
||||
else
|
||||
if hasMultilines
|
||||
then colorMultilinePrefix " " <> space
|
||||
else mempty
|
||||
in -- get the maximum end column, so that we know when to stop looking for other markers on the same line
|
||||
hardline <+> dotPrefix leftLen withUnicode <+> (if List.null ms then mempty else specialPrefix <> showMarkers 1 maxMarkerColumn <> showMessages specialPrefix ms maxMarkerColumn)
|
||||
where
|
||||
showMarkers n lineLen
|
||||
| n > lineLen = mempty -- reached the end of the line
|
||||
| otherwise =
|
||||
let allMarkers = flip filter ms \ (Position (_, bc) (_, ec) _, _) -> n >= bc && n < ec
|
||||
-- only consider markers which span onto the current column
|
||||
in case allMarkers of
|
||||
[] -> space <> showMarkers (n + 1) lineLen
|
||||
(Position{..},marker):_ ->
|
||||
| n > lineLen = mempty -- reached the end of the line
|
||||
| otherwise =
|
||||
let allMarkers = flip filter ms \(Position (_, bc) (_, ec) _, _) -> n >= bc && n < ec
|
||||
in -- only consider markers which span onto the current column
|
||||
case allMarkers of
|
||||
[] -> space <> showMarkers (n + 1) lineLen
|
||||
(Position {..}, marker) : _ ->
|
||||
if snd begin == n
|
||||
then annotate (markerColor isError marker) (if withUnicode then "┬" else "^") <> showMarkers (n + 1) lineLen
|
||||
else annotate (markerColor isError marker) (if withUnicode then "─" else "-") <> showMarkers (n + 1) lineLen
|
||||
-- if the marker just started on this column, output a caret, else output a dash
|
||||
then annotate (markerColor isError marker) (if withUnicode then "┬" else "^") <> showMarkers (n + 1) lineLen
|
||||
else annotate (markerColor isError marker) (if withUnicode then "─" else "-") <> showMarkers (n + 1) lineLen
|
||||
-- if the marker just started on this column, output a caret, else output a dash
|
||||
|
||||
showMessages specialPrefix ms lineLen = case List.safeUncons ms of
|
||||
Nothing -> mempty -- no more messages to show
|
||||
Nothing -> mempty -- no more messages to show
|
||||
Just ((Position b@(_, bc) _ _, msg), pipes) ->
|
||||
let filteredPipes = filter ((/= b) . begin . fst) pipes
|
||||
-- record only the pipes corresponding to markers on different starting positions
|
||||
nubbedPipes = List.nubBy ((==) `on` (begin . fst)) filteredPipes
|
||||
-- and then remove all duplicates
|
||||
|
||||
allColumns _ [] = (1, [])
|
||||
allColumns _ [] = (1, [])
|
||||
allColumns n ms@((Position (_, bc) _ _, col) : ms')
|
||||
| n == bc = bimap (+ 1) (col :) (allColumns (n + 1) ms')
|
||||
| n < bc = bimap (+ 1) (space :) (allColumns (n + 1) ms)
|
||||
| otherwise = bimap (+ 1) (space :) (allColumns (n + 1) ms')
|
||||
-- transform the list of remaining markers into a single document line
|
||||
| n == bc = bimap (+ 1) (col :) (allColumns (n + 1) ms')
|
||||
| n < bc = bimap (+ 1) (space :) (allColumns (n + 1) ms)
|
||||
| otherwise = bimap (+ 1) (space :) (allColumns (n + 1) ms')
|
||||
-- transform the list of remaining markers into a single document line
|
||||
|
||||
hasSuccessor = length filteredPipes /= length pipes
|
||||
|
||||
lineStart pipes =
|
||||
let (n, docs) = allColumns 1 $ List.sortOn (snd . begin . fst) pipes
|
||||
in dotPrefix leftLen withUnicode <+> specialPrefix <> fold docs <> pretty (replicate (bc - n) ' ')
|
||||
-- the start of the line contains the "dot"-prefix as well as all the pipes for all the still not rendered marker messages
|
||||
in dotPrefix leftLen withUnicode <+> specialPrefix <> fold docs <> pretty (replicate (bc - n) ' ')
|
||||
-- the start of the line contains the "dot"-prefix as well as all the pipes for all the still not rendered marker messages
|
||||
|
||||
prefix =
|
||||
let (pipesBefore, pipesAfter) = List.partition ((< bc) . snd . begin . fst) nubbedPipes
|
||||
-- split the list so that all pipes before can have `|`s but pipes after won't
|
||||
|
||||
pipesBeforeRendered = pipesBefore <&> second \ marker -> annotate (markerColor isError marker) (if withUnicode then "│" else "|")
|
||||
pipesBeforeRendered = pipesBefore <&> second \marker -> annotate (markerColor isError marker) (if withUnicode then "│" else "|")
|
||||
-- pre-render pipes which are before because they will be shown
|
||||
|
||||
lastBeginPosition = snd . begin . fst <$> List.safeLast (List.sortOn (Down . snd . begin . fst) pipesAfter)
|
||||
|
||||
lineLen = case lastBeginPosition of
|
||||
Nothing -> 0
|
||||
Nothing -> 0
|
||||
Just col -> col - bc
|
||||
|
||||
currentPipe = if | withUnicode && hasSuccessor -> "├"
|
||||
| withUnicode -> "╰"
|
||||
| hasSuccessor -> "|"
|
||||
| otherwise -> "`"
|
||||
currentPipe =
|
||||
if
|
||||
| withUnicode && hasSuccessor -> "├"
|
||||
| withUnicode -> "╰"
|
||||
| hasSuccessor -> "|"
|
||||
| otherwise -> "`"
|
||||
|
||||
lineChar = if withUnicode then '─' else '-'
|
||||
pointChar = if withUnicode then "╸" else "-"
|
||||
|
||||
in lineStart pipesBeforeRendered
|
||||
<> annotate (markerColor isError msg) (currentPipe <> pretty (replicate lineLen lineChar) <> pointChar)
|
||||
<+> annotate (markerColor isError msg) (replaceLinesWith (hardline <+> lineStart pipesBeforeRendered <+> " ") $ pretty $ markerMessage msg)
|
||||
|
||||
in hardline <+> prefix <> showMessages specialPrefix pipes lineLen
|
||||
in lineStart pipesBeforeRendered
|
||||
<> annotate (markerColor isError msg) (currentPipe <> pretty (replicate lineLen lineChar) <> pointChar)
|
||||
<+> annotate (markerColor isError msg) (replaceLinesWith (hardline <+> lineStart pipesBeforeRendered <+> " ") $ pretty $ markerMessage msg)
|
||||
in hardline <+> prefix <> showMessages specialPrefix pipes lineLen
|
||||
|
||||
-- WARN: uses the internal of the library
|
||||
--
|
||||
-- DO NOT use a wildcard here, in case the internal API exposes one more constructor
|
||||
|
||||
-- |
|
||||
replaceLinesWith :: Doc ann -> Doc ann -> Doc ann
|
||||
replaceLinesWith repl Line = repl
|
||||
replaceLinesWith _ Fail = Fail
|
||||
replaceLinesWith _ Empty = Empty
|
||||
replaceLinesWith _ (Char c) = Char c
|
||||
replaceLinesWith _ (Text n s) = Text n s
|
||||
replaceLinesWith repl (FlatAlt f d) = FlatAlt (replaceLinesWith repl f) (replaceLinesWith repl d)
|
||||
replaceLinesWith repl (Cat c d) = Cat (replaceLinesWith repl c) (replaceLinesWith repl d)
|
||||
replaceLinesWith repl (Nest n d) = Nest n (replaceLinesWith repl d)
|
||||
replaceLinesWith repl (Union c d) = Union (replaceLinesWith repl c) (replaceLinesWith repl d)
|
||||
replaceLinesWith repl (Column f) = Column (replaceLinesWith repl . f)
|
||||
replaceLinesWith repl (Nesting f) = Nesting (replaceLinesWith repl . f)
|
||||
replaceLinesWith repl (Annotated ann doc) = Annotated ann (replaceLinesWith repl doc)
|
||||
replaceLinesWith repl (WithPageWidth f) = WithPageWidth (replaceLinesWith repl . f)
|
||||
replaceLinesWith repl Line = repl
|
||||
replaceLinesWith _ Fail = Fail
|
||||
replaceLinesWith _ Empty = Empty
|
||||
replaceLinesWith _ (Char c) = Char c
|
||||
replaceLinesWith _ (Text n s) = Text n s
|
||||
replaceLinesWith repl (FlatAlt f d) = FlatAlt (replaceLinesWith repl f) (replaceLinesWith repl d)
|
||||
replaceLinesWith repl (Cat c d) = Cat (replaceLinesWith repl c) (replaceLinesWith repl d)
|
||||
replaceLinesWith repl (Nest n d) = Nest n (replaceLinesWith repl d)
|
||||
replaceLinesWith repl (Union c d) = Union (replaceLinesWith repl c) (replaceLinesWith repl d)
|
||||
replaceLinesWith repl (Column f) = Column (replaceLinesWith repl . f)
|
||||
replaceLinesWith repl (Nesting f) = Nesting (replaceLinesWith repl . f)
|
||||
replaceLinesWith repl (Annotated ann doc) = Annotated ann (replaceLinesWith repl doc)
|
||||
replaceLinesWith repl (WithPageWidth f) = WithPageWidth (replaceLinesWith repl . f)
|
||||
|
||||
-- | Extracts the color of a marker as a 'Doc' coloring function.
|
||||
markerColor :: Bool -- ^ Whether the marker is in an error context or not.
|
||||
-- This really makes a difference for a 'This' marker.
|
||||
-> Marker msg -- ^ The marker to extract the color from.
|
||||
-> AnsiStyle -- ^ A function used to color a 'Doc'.
|
||||
markerColor ::
|
||||
-- | Whether the marker is in an error context or not.
|
||||
-- This really makes a difference for a 'This' marker.
|
||||
Bool ->
|
||||
-- | The marker to extract the color from.
|
||||
Marker msg ->
|
||||
-- | A function used to color a 'Doc'.
|
||||
AnsiStyle
|
||||
markerColor isError (This _) = if isError then color Red else color Yellow
|
||||
markerColor _ (Where _) = colorDull Blue
|
||||
markerColor _ (Maybe _) = color Magenta
|
||||
markerColor _ (Where _) = colorDull Blue
|
||||
markerColor _ (Maybe _) = color Magenta
|
||||
{-# INLINE markerColor #-}
|
||||
|
||||
-- | Retrieves the message held by a marker.
|
||||
markerMessage :: Marker msg -> msg
|
||||
markerMessage (This m) = m
|
||||
markerMessage (This m) = m
|
||||
markerMessage (Where m) = m
|
||||
markerMessage (Maybe m) = m
|
||||
{-# INLINE markerMessage #-}
|
||||
|
||||
-- | Pretty prints all hints.
|
||||
prettyAllHints :: Pretty msg => [msg] -> Int -> Bool -> Doc AnsiStyle
|
||||
prettyAllHints [] _ _ = mempty
|
||||
prettyAllHints [] _ _ = mempty
|
||||
prettyAllHints (h : hs) leftLen withUnicode =
|
||||
{-
|
||||
A hint is composed of:
|
||||
(1) : Hint: <hint message>
|
||||
-}
|
||||
{-
|
||||
A hint is composed of:
|
||||
(1) : Hint: <hint message>
|
||||
-}
|
||||
let prefix = hardline <+> pipePrefix leftLen withUnicode
|
||||
in prefix <+> annotate (color Cyan) (annotate bold "Hint:" <+> replaceLinesWith (prefix <+> " ") (pretty h))
|
||||
<> prettyAllHints hs leftLen withUnicode
|
||||
in prefix <+> annotate (color Cyan) (annotate bold "Hint:" <+> replaceLinesWith (prefix <+> " ") (pretty h))
|
||||
<> prettyAllHints hs leftLen withUnicode
|
||||
|
@ -1,67 +1,69 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
import Error.Diagnose
|
||||
( printDiagnostic,
|
||||
#ifdef USE_AESON
|
||||
diagnosticToJson,
|
||||
#endif
|
||||
stdout,
|
||||
err,
|
||||
warn,
|
||||
Marker(..),
|
||||
Report,
|
||||
Position(..),
|
||||
addFile,
|
||||
addReport,
|
||||
def )
|
||||
|
||||
#ifdef USE_AESON
|
||||
import qualified Data.ByteString.Lazy as BS
|
||||
#endif
|
||||
import Data.HashMap.Lazy (HashMap)
|
||||
import qualified Data.HashMap.Lazy as HashMap
|
||||
|
||||
import Error.Diagnose
|
||||
( Marker (..),
|
||||
Position (..),
|
||||
Report,
|
||||
addFile,
|
||||
addReport,
|
||||
def,
|
||||
err,
|
||||
printDiagnostic,
|
||||
stdout,
|
||||
warn,
|
||||
)
|
||||
import System.IO (hPutStrLn)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
let files :: HashMap FilePath String = HashMap.fromList
|
||||
[ ("test.zc", "let id<a>(x : a) : a := x + 1\nrec fix(f) := f(fix(f))\nlet const<a, b>(x : a, y : b) : a := x")
|
||||
, ("somefile.zc", "let id<a>(x : a) : a := x\n + 1")
|
||||
, ("err.nst", "\n\n\n\n = jmp g\n\n g: forall(s: Ts, e: Tc).{ %r0: *s64 | s -> e }")
|
||||
, ("unsized.nst", "main: forall(a: Ta, s: Ts, e: Tc).{ %r5: forall().{| s -> e } | s -> %r5 }\n = salloc a\n ; sfree\n")
|
||||
]
|
||||
let files :: HashMap FilePath String =
|
||||
HashMap.fromList
|
||||
[ ("test.zc", "let id<a>(x : a) : a := x + 1\nrec fix(f) := f(fix(f))\nlet const<a, b>(x : a, y : b) : a := x"),
|
||||
("somefile.zc", "let id<a>(x : a) : a := x\n + 1"),
|
||||
("err.nst", "\n\n\n\n = jmp g\n\n g: forall(s: Ts, e: Tc).{ %r0: *s64 | s -> e }"),
|
||||
("unsized.nst", "main: forall(a: Ta, s: Ts, e: Tc).{ %r5: forall().{| s -> e } | s -> %r5 }\n = salloc a\n ; sfree\n")
|
||||
]
|
||||
|
||||
let reports =
|
||||
[ errorNoMarkersNoHints
|
||||
, errorSingleMarkerNoHints
|
||||
, warningSingleMarkerNoHints
|
||||
, errorTwoMarkersSameLineNoOverlapNoHints
|
||||
, errorSingleMarkerOutOfBoundsNoHints
|
||||
, errorTwoMarkersSameLineOverlapNoHints
|
||||
, errorTwoMarkersSameLinePartialOverlapNoHints
|
||||
, errorTwoMarkersTwoLinesNoHints
|
||||
, realWorldExample
|
||||
, errorTwoMarkersSamePositionNoHints
|
||||
, errorThreeMarkersWithOverlapNoHints
|
||||
, errorWithMultilineErrorNoMarkerNoHints
|
||||
, errorSingleMultilineMarkerMessageNoHints
|
||||
, errorTwoMarkersSameOriginOverlapNoHints
|
||||
, errorNoMarkersSingleHint
|
||||
, errorNoMarkersSingleMultilineHint
|
||||
, errorNoMarkersTwoHints
|
||||
, errorSingleMultilineMarkerNoHints
|
||||
, errorTwoMarkersWithMultilineNoHints
|
||||
, errorTwoMultilineMarkersNoHints
|
||||
, errorSingleMultilineMarkerMultilineMessageNoHints
|
||||
, errorTwoMultilineMarkersFirstMultilineMessageNoHints
|
||||
, errorThreeMultilineMarkersTwoMultilineMessageNoHints
|
||||
, errorOrderSensitive
|
||||
, errorMultilineAfterSingleLine
|
||||
, errorOnEmptyLine
|
||||
, beautifulExample
|
||||
]
|
||||
[ errorNoMarkersNoHints,
|
||||
errorSingleMarkerNoHints,
|
||||
warningSingleMarkerNoHints,
|
||||
errorTwoMarkersSameLineNoOverlapNoHints,
|
||||
errorSingleMarkerOutOfBoundsNoHints,
|
||||
errorTwoMarkersSameLineOverlapNoHints,
|
||||
errorTwoMarkersSameLinePartialOverlapNoHints,
|
||||
errorTwoMarkersTwoLinesNoHints,
|
||||
realWorldExample,
|
||||
errorTwoMarkersSamePositionNoHints,
|
||||
errorThreeMarkersWithOverlapNoHints,
|
||||
errorWithMultilineErrorNoMarkerNoHints,
|
||||
errorSingleMultilineMarkerMessageNoHints,
|
||||
errorTwoMarkersSameOriginOverlapNoHints,
|
||||
errorNoMarkersSingleHint,
|
||||
errorNoMarkersSingleMultilineHint,
|
||||
errorNoMarkersTwoHints,
|
||||
errorSingleMultilineMarkerNoHints,
|
||||
errorTwoMarkersWithMultilineNoHints,
|
||||
errorTwoMultilineMarkersNoHints,
|
||||
errorSingleMultilineMarkerMultilineMessageNoHints,
|
||||
errorTwoMultilineMarkersFirstMultilineMessageNoHints,
|
||||
errorThreeMultilineMarkersTwoMultilineMessageNoHints,
|
||||
errorOrderSensitive,
|
||||
errorMultilineAfterSingleLine,
|
||||
errorOnEmptyLine,
|
||||
errorMultipleFiles,
|
||||
beautifulExample
|
||||
]
|
||||
|
||||
let diag = HashMap.foldlWithKey' addFile (foldr (flip addReport) def reports) files
|
||||
|
||||
@ -77,182 +79,234 @@ main = do
|
||||
|
||||
errorNoMarkersNoHints :: Report String
|
||||
errorNoMarkersNoHints =
|
||||
err "Error with no marker"
|
||||
err
|
||||
"Error with no marker"
|
||||
[]
|
||||
[]
|
||||
|
||||
errorSingleMarkerNoHints :: Report String
|
||||
errorSingleMarkerNoHints =
|
||||
err "Error with one marker in bounds"
|
||||
[ (Position (1, 25) (1, 30) "test.zc", This "Required here") ]
|
||||
err
|
||||
"Error with one marker in bounds"
|
||||
[(Position (1, 25) (1, 30) "test.zc", This "Required here")]
|
||||
[]
|
||||
|
||||
warningSingleMarkerNoHints :: Report String
|
||||
warningSingleMarkerNoHints =
|
||||
warn "Warning with one marker in bounds"
|
||||
[ (Position (1, 25) (1, 30) "test.zc", This "Required here") ]
|
||||
warn
|
||||
"Warning with one marker in bounds"
|
||||
[(Position (1, 25) (1, 30) "test.zc", This "Required here")]
|
||||
[]
|
||||
|
||||
errorTwoMarkersSameLineNoOverlapNoHints :: Report String
|
||||
errorTwoMarkersSameLineNoOverlapNoHints =
|
||||
err "Error with two markers in bounds (no overlap) on the same line"
|
||||
[ (Position (1, 5) (1, 10) "test.zc", This "First")
|
||||
, (Position (1, 15) (1, 22) "test.zc", Where "Second") ]
|
||||
err
|
||||
"Error with two markers in bounds (no overlap) on the same line"
|
||||
[ (Position (1, 5) (1, 10) "test.zc", This "First"),
|
||||
(Position (1, 15) (1, 22) "test.zc", Where "Second")
|
||||
]
|
||||
[]
|
||||
|
||||
errorSingleMarkerOutOfBoundsNoHints :: Report String
|
||||
errorSingleMarkerOutOfBoundsNoHints =
|
||||
err "Error with one marker out of bounds"
|
||||
[ (Position (10, 5) (10, 15) "test2.zc", This "Out of bounds") ]
|
||||
err
|
||||
"Error with one marker out of bounds"
|
||||
[(Position (10, 5) (10, 15) "test2.zc", This "Out of bounds")]
|
||||
[]
|
||||
|
||||
errorTwoMarkersSameLineOverlapNoHints :: Report String
|
||||
errorTwoMarkersSameLineOverlapNoHints =
|
||||
err "Error with two overlapping markers in bounds"
|
||||
[ (Position (1, 6) (1, 13) "test.zc", This "First")
|
||||
, (Position (1, 10) (1, 15) "test.zc", Where "Second") ]
|
||||
err
|
||||
"Error with two overlapping markers in bounds"
|
||||
[ (Position (1, 6) (1, 13) "test.zc", This "First"),
|
||||
(Position (1, 10) (1, 15) "test.zc", Where "Second")
|
||||
]
|
||||
[]
|
||||
|
||||
errorTwoMarkersSameLinePartialOverlapNoHints :: Report String
|
||||
errorTwoMarkersSameLinePartialOverlapNoHints =
|
||||
err "Error with two partially overlapping markers in bounds"
|
||||
[ (Position (1, 5) (1, 25) "test.zc", This "First")
|
||||
, (Position (1, 12) (1, 20) "test.zc", Where "Second") ]
|
||||
err
|
||||
"Error with two partially overlapping markers in bounds"
|
||||
[ (Position (1, 5) (1, 25) "test.zc", This "First"),
|
||||
(Position (1, 12) (1, 20) "test.zc", Where "Second")
|
||||
]
|
||||
[]
|
||||
|
||||
errorTwoMarkersTwoLinesNoHints :: Report String
|
||||
errorTwoMarkersTwoLinesNoHints =
|
||||
err "Error with two markers on two lines in bounds"
|
||||
[ (Position (1, 5) (1, 12) "test.zc", This "First")
|
||||
, (Position (2, 3) (2, 4) "test.zc", Where "Second") ]
|
||||
err
|
||||
"Error with two markers on two lines in bounds"
|
||||
[ (Position (1, 5) (1, 12) "test.zc", This "First"),
|
||||
(Position (2, 3) (2, 4) "test.zc", Where "Second")
|
||||
]
|
||||
[]
|
||||
|
||||
realWorldExample :: Report String
|
||||
realWorldExample =
|
||||
err "Could not deduce constraint 'Num(a)' from the current context"
|
||||
[ (Position (1, 25) (1, 30) "test.zc", This "While applying function '+'")
|
||||
, (Position (1, 11) (1, 16) "test.zc", Where "'x' is supposed to have type 'a'")
|
||||
, (Position (1, 8) (1, 9) "test.zc", Where "type 'a' is bound here without constraints") ]
|
||||
[ "Adding 'Num(a)' to the list of constraints may solve this problem." ]
|
||||
err
|
||||
"Could not deduce constraint 'Num(a)' from the current context"
|
||||
[ (Position (1, 25) (1, 30) "test.zc", This "While applying function '+'"),
|
||||
(Position (1, 11) (1, 16) "test.zc", Where "'x' is supposed to have type 'a'"),
|
||||
(Position (1, 8) (1, 9) "test.zc", Where "type 'a' is bound here without constraints")
|
||||
]
|
||||
["Adding 'Num(a)' to the list of constraints may solve this problem."]
|
||||
|
||||
errorTwoMarkersSamePositionNoHints :: Report String
|
||||
errorTwoMarkersSamePositionNoHints =
|
||||
err "Error with two markers on the same exact position in bounds"
|
||||
[ (Position (1, 6) (1, 10) "test.zc", This "First")
|
||||
, (Position (1, 6) (1, 10) "test.zc", Maybe "Second") ]
|
||||
err
|
||||
"Error with two markers on the same exact position in bounds"
|
||||
[ (Position (1, 6) (1, 10) "test.zc", This "First"),
|
||||
(Position (1, 6) (1, 10) "test.zc", Maybe "Second")
|
||||
]
|
||||
[]
|
||||
|
||||
errorThreeMarkersWithOverlapNoHints :: Report String
|
||||
errorThreeMarkersWithOverlapNoHints =
|
||||
err "Error with three markers with overlapping in bounds"
|
||||
[ (Position (1, 9) (1, 15) "test.zc", This "First")
|
||||
, (Position (1, 9) (1, 18) "test.zc", Maybe "Second")
|
||||
, (Position (1, 6) (1, 10) "test.zc", Where "Third") ]
|
||||
err
|
||||
"Error with three markers with overlapping in bounds"
|
||||
[ (Position (1, 9) (1, 15) "test.zc", This "First"),
|
||||
(Position (1, 9) (1, 18) "test.zc", Maybe "Second"),
|
||||
(Position (1, 6) (1, 10) "test.zc", Where "Third")
|
||||
]
|
||||
[]
|
||||
|
||||
errorWithMultilineErrorNoMarkerNoHints :: Report String
|
||||
errorWithMultilineErrorNoMarkerNoHints =
|
||||
err "Error with multi\nline message and no markers"
|
||||
err
|
||||
"Error with multi\nline message and no markers"
|
||||
[]
|
||||
[]
|
||||
|
||||
errorSingleMultilineMarkerMessageNoHints :: Report String
|
||||
errorSingleMultilineMarkerMessageNoHints =
|
||||
err "Error with single marker with multiline message"
|
||||
[ (Position (1, 9) (1, 15) "test.zc", This "First\nmultiline") ]
|
||||
err
|
||||
"Error with single marker with multiline message"
|
||||
[(Position (1, 9) (1, 15) "test.zc", This "First\nmultiline")]
|
||||
[]
|
||||
|
||||
errorTwoMarkersSameOriginOverlapNoHints :: Report String
|
||||
errorTwoMarkersSameOriginOverlapNoHints =
|
||||
err "Error with two markers with same origin but partial overlap in bounds"
|
||||
[ (Position (1, 9) (1, 15) "test.zc", This "First")
|
||||
, (Position (1, 9) (1, 20) "test.zc", Maybe "Second") ]
|
||||
err
|
||||
"Error with two markers with same origin but partial overlap in bounds"
|
||||
[ (Position (1, 9) (1, 15) "test.zc", This "First"),
|
||||
(Position (1, 9) (1, 20) "test.zc", Maybe "Second")
|
||||
]
|
||||
[]
|
||||
|
||||
errorNoMarkersSingleHint :: Report String
|
||||
errorNoMarkersSingleHint =
|
||||
err "Error with no marker and one hint"
|
||||
err
|
||||
"Error with no marker and one hint"
|
||||
[]
|
||||
[ "First hint" ]
|
||||
["First hint"]
|
||||
|
||||
errorNoMarkersSingleMultilineHint :: Report String
|
||||
errorNoMarkersSingleMultilineHint =
|
||||
err "Error with no marker and one multiline hint"
|
||||
err
|
||||
"Error with no marker and one multiline hint"
|
||||
[]
|
||||
[ "First multi\nline hint" ]
|
||||
["First multi\nline hint"]
|
||||
|
||||
errorNoMarkersTwoHints :: Report String
|
||||
errorNoMarkersTwoHints =
|
||||
err "Error with no markers and two hints"
|
||||
err
|
||||
"Error with no markers and two hints"
|
||||
[]
|
||||
[ "First hint"
|
||||
, "Second hint" ]
|
||||
[ "First hint",
|
||||
"Second hint"
|
||||
]
|
||||
|
||||
errorSingleMultilineMarkerNoHints :: Report String
|
||||
errorSingleMultilineMarkerNoHints =
|
||||
err "Error with single marker spanning across multiple lines"
|
||||
[ (Position (1, 15) (2, 6) "test.zc", This "First") ]
|
||||
err
|
||||
"Error with single marker spanning across multiple lines"
|
||||
[(Position (1, 15) (2, 6) "test.zc", This "First")]
|
||||
[]
|
||||
|
||||
errorTwoMarkersWithMultilineNoHints :: Report String
|
||||
errorTwoMarkersWithMultilineNoHints =
|
||||
err "Error with two markers, one single line and one multiline, in bounds"
|
||||
[ (Position (1, 9) (1, 13) "test.zc", This "First")
|
||||
, (Position (1, 14) (2, 6) "test.zc", Where "Second") ]
|
||||
err
|
||||
"Error with two markers, one single line and one multiline, in bounds"
|
||||
[ (Position (1, 9) (1, 13) "test.zc", This "First"),
|
||||
(Position (1, 14) (2, 6) "test.zc", Where "Second")
|
||||
]
|
||||
[]
|
||||
|
||||
errorTwoMultilineMarkersNoHints :: Report String
|
||||
errorTwoMultilineMarkersNoHints =
|
||||
err "Error with two multiline markers in bounds"
|
||||
[ (Position (1, 9) (2, 5) "test.zc", This "First")
|
||||
, (Position (2, 1) (3, 10) "test.zc", Where "Second") ]
|
||||
err
|
||||
"Error with two multiline markers in bounds"
|
||||
[ (Position (1, 9) (2, 5) "test.zc", This "First"),
|
||||
(Position (2, 1) (3, 10) "test.zc", Where "Second")
|
||||
]
|
||||
[]
|
||||
|
||||
errorSingleMultilineMarkerMultilineMessageNoHints :: Report String
|
||||
errorSingleMultilineMarkerMultilineMessageNoHints =
|
||||
err "Error with one multiline marker with a multiline message in bounds"
|
||||
[ (Position (1, 9) (2, 5) "test.zc", This "Multi\nline message") ]
|
||||
err
|
||||
"Error with one multiline marker with a multiline message in bounds"
|
||||
[(Position (1, 9) (2, 5) "test.zc", This "Multi\nline message")]
|
||||
[]
|
||||
|
||||
errorTwoMultilineMarkersFirstMultilineMessageNoHints :: Report String
|
||||
errorTwoMultilineMarkersFirstMultilineMessageNoHints =
|
||||
err "Error with two multiline markers with one multiline message in bounds"
|
||||
[ (Position (1, 9) (2, 5) "test.zc", This "First")
|
||||
, (Position (1, 9) (2, 6) "test.zc", Where "Multi\nline message") ]
|
||||
err
|
||||
"Error with two multiline markers with one multiline message in bounds"
|
||||
[ (Position (1, 9) (2, 5) "test.zc", This "First"),
|
||||
(Position (1, 9) (2, 6) "test.zc", Where "Multi\nline message")
|
||||
]
|
||||
[]
|
||||
|
||||
errorThreeMultilineMarkersTwoMultilineMessageNoHints :: Report String
|
||||
errorThreeMultilineMarkersTwoMultilineMessageNoHints =
|
||||
err "Error with three multiline markers with two multiline messages in bounds"
|
||||
[ (Position (1, 9) (2, 5) "test.zc", This "First")
|
||||
, (Position (1, 9) (2, 6) "test.zc", Where "Multi\nline message")
|
||||
, (Position (1, 9) (2, 7) "test.zc", Maybe "Multi\nline message #2") ]
|
||||
err
|
||||
"Error with three multiline markers with two multiline messages in bounds"
|
||||
[ (Position (1, 9) (2, 5) "test.zc", This "First"),
|
||||
(Position (1, 9) (2, 6) "test.zc", Where "Multi\nline message"),
|
||||
(Position (1, 9) (2, 7) "test.zc", Maybe "Multi\nline message #2")
|
||||
]
|
||||
[]
|
||||
|
||||
errorOrderSensitive :: Report String
|
||||
errorOrderSensitive =
|
||||
err "Order-sensitive labels with crossing"
|
||||
[ (Position (1, 1) (1, 7) "somefile.zc", This "Leftmost label")
|
||||
, (Position (1, 9) (1, 16) "somefile.zc", Where "Rightmost label") ]
|
||||
err
|
||||
"Order-sensitive labels with crossing"
|
||||
[ (Position (1, 1) (1, 7) "somefile.zc", This "Leftmost label"),
|
||||
(Position (1, 9) (1, 16) "somefile.zc", Where "Rightmost label")
|
||||
]
|
||||
[]
|
||||
|
||||
beautifulExample :: Report String
|
||||
beautifulExample =
|
||||
err "Could not deduce constraint 'Num(a)' from the current context"
|
||||
[ (Position (1, 25) (2, 6) "somefile.zc", This "While applying function '+'")
|
||||
, (Position (1, 11) (1, 16) "somefile.zc", Where "'x' is supposed to have type 'a'")
|
||||
, (Position (1, 8) (1, 9) "somefile.zc", Where "type 'a' is bound here without constraints") ]
|
||||
[ "Adding 'Num(a)' to the list of constraints may solve this problem." ]
|
||||
err
|
||||
"Could not deduce constraint 'Num(a)' from the current context"
|
||||
[ (Position (1, 25) (2, 6) "somefile.zc", This "While applying function '+'"),
|
||||
(Position (1, 11) (1, 16) "somefile.zc", Where "'x' is supposed to have type 'a'"),
|
||||
(Position (1, 8) (1, 9) "somefile.zc", Where "type 'a' is bound here without constraints")
|
||||
]
|
||||
["Adding 'Num(a)' to the list of constraints may solve this problem."]
|
||||
|
||||
errorMultilineAfterSingleLine :: Report String
|
||||
errorMultilineAfterSingleLine =
|
||||
err "Multiline after single line"
|
||||
[ (Position (1, 17) (1, 18) "unsized.nst", Where "Kind is infered from here")
|
||||
, (Position (2, 14) (3, 0) "unsized.nst", This "is an error") ]
|
||||
err
|
||||
"Multiline after single line"
|
||||
[ (Position (1, 17) (1, 18) "unsized.nst", Where "Kind is infered from here"),
|
||||
(Position (2, 14) (3, 0) "unsized.nst", This "is an error")
|
||||
]
|
||||
[]
|
||||
|
||||
errorOnEmptyLine :: Report String
|
||||
errorOnEmptyLine =
|
||||
err "Error on empty line"
|
||||
[ (Position (1, 5) (3, 8) "err.nst", This "error on empty line") ]
|
||||
err
|
||||
"Error on empty line"
|
||||
[(Position (1, 5) (3, 8) "err.nst", This "error on empty line")]
|
||||
[]
|
||||
|
||||
errorMultipleFiles :: Report String
|
||||
errorMultipleFiles =
|
||||
err
|
||||
"Error on multiple files"
|
||||
[ (Position (1, 5) (1, 7) "test.zc", Where "Function already declared here"),
|
||||
(Position (1, 5) (1, 7) "somefile.zc", This "Function `id` is already declared in another module")
|
||||
]
|
||||
[]
|
||||
|
Loading…
Reference in New Issue
Block a user