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

correctly output reports with multiple files

Browse Source
This commit is contained in:
Mesabloo 2022-04-21 12:00:41 +02:00
parent 26f5639dc5
commit 79020a3b30
2 changed files with 487 additions and 337 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

296
test/rendering/Spec.hs
View File

@ -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")
]
[]