mirror of
https://github.com/Mesabloo/diagnose.git
synced 2024-11-22 01:32:56 +03:00
diagnose: rewrite the whole library
This commit is contained in:
Mesabloo
parent
00de50a0d0
commit
402bb22274
@ -20,6 +20,14 @@ source-repository head
|
||||
location: https://github.com/mesabloo/nihil
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Data.List.Safe
|
||||
Error.Diagnose
|
||||
Error.Diagnose.Diagnostic
|
||||
Error.Diagnose.Diagnostic.Internal
|
||||
Error.Diagnose.Position
|
||||
Error.Diagnose.Report
|
||||
Error.Diagnose.Report.Internal
|
||||
other-modules:
|
||||
Paths_diagnose
|
||||
hs-source-dirs:
|
||||
@ -32,4 +40,29 @@ library
|
||||
ansi-wl-pprint
|
||||
, base >=4.7 && <5
|
||||
, containers
|
||||
, data-default
|
||||
, hashable
|
||||
, unordered-containers
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite diagnose-tests
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
Paths_diagnose
|
||||
hs-source-dirs:
|
||||
test
|
||||
default-extensions:
|
||||
OverloadedStrings
|
||||
LambdaCase
|
||||
BlockArguments
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
ansi-wl-pprint
|
||||
, base >=4.7 && <5
|
||||
, containers
|
||||
, data-default
|
||||
, diagnose
|
||||
, hashable
|
||||
, unordered-containers
|
||||
default-language: Haskell2010
|
||||
|
||||
6
hie.yaml
Normal file
6
hie.yaml
Normal file
@ -0,0 +1,6 @@
|
||||
cradle:
|
||||
stack:
|
||||
- path: "./test"
|
||||
component: "diagnose:test:diagnose-tests"
|
||||
- path: "./src"
|
||||
component: "diagnose:lib"
|
||||
14
package.yaml
14
package.yaml
@ -9,6 +9,9 @@ dependencies:
|
||||
- base >= 4.7 && < 5
|
||||
- ansi-wl-pprint
|
||||
- containers
|
||||
- unordered-containers
|
||||
- hashable
|
||||
- data-default
|
||||
|
||||
default-extensions:
|
||||
- OverloadedStrings
|
||||
@ -17,3 +20,14 @@ default-extensions:
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
|
||||
tests:
|
||||
diagnose-tests:
|
||||
main: Spec.hs
|
||||
source-dirs: test
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- diagnose
|
||||
|
||||
35
src/Data/List/Safe.hs
Normal file
35
src/Data/List/Safe.hs
Normal file
@ -0,0 +1,35 @@
|
||||
module Data.List.Safe where
|
||||
|
||||
import Data.Bifunctor (first)
|
||||
|
||||
|
||||
-- | Analogous to 'Data.List.last', but returns 'Nothing' on an empty list, instead of throwing an error.
|
||||
safeLast :: [a] -> Maybe a
|
||||
safeLast [] = Nothing
|
||||
safeLast l = Just $ last l
|
||||
|
||||
-- | Analogous to `Data.List.head`, but returns 'Nothing' in case of an empty list.
|
||||
safeHead :: [a] -> Maybe a
|
||||
safeHead [] = Nothing
|
||||
safeHead (x : _) = Just x
|
||||
|
||||
-- | Analogous tu 'Data.List.!!', but does not throw an error on missing index.
|
||||
safeIndex :: Int -> [a] -> Maybe a
|
||||
safeIndex _ [] = Nothing
|
||||
safeIndex 0 (x : xs) = Just x
|
||||
safeIndex n (_ : xs)
|
||||
| n < 0 = Nothing
|
||||
| otherwise = safeIndex (n - 1) xs
|
||||
|
||||
-- | Safely deconstructs a list from the end.
|
||||
--
|
||||
-- More efficient than @(init x, last x)@
|
||||
safeUnsnoc :: [a] -> Maybe ([a], a)
|
||||
safeUnsnoc [] = Nothing
|
||||
safeUnsnoc [x] = Just ([], x)
|
||||
safeUnsnoc (x : xs) = first (x :) <$> safeUnsnoc xs
|
||||
|
||||
-- | Safely deconstructs a list from the beginning, returning 'Nothing' if the list is empty.
|
||||
safeUncons :: [a] -> Maybe (a, [a])
|
||||
safeUncons [] = Nothing
|
||||
safeUncons (x : xs) = Just (x, xs)
|
||||
7
src/Error/Diagnose.hs
Normal file
7
src/Error/Diagnose.hs
Normal file
@ -0,0 +1,7 @@
|
||||
module Error.Diagnose
|
||||
( -- * Re-exports
|
||||
module Export ) where
|
||||
|
||||
import Error.Diagnose.Position as Export
|
||||
import Error.Diagnose.Report as Export
|
||||
import Error.Diagnose.Diagnostic as Export
|
||||
15
src/Error/Diagnose/Diagnostic.hs
Normal file
15
src/Error/Diagnose/Diagnostic.hs
Normal file
@ -0,0 +1,15 @@
|
||||
{-|
|
||||
Module : Error.Diagnose.Diagnostic
|
||||
Description : Diagnostic definition and pretty printing
|
||||
Copyright : (c) Mesabloo, 2021
|
||||
License : BSD3
|
||||
Stability : experimental
|
||||
Portability : Portable
|
||||
-}
|
||||
module Error.Diagnose.Diagnostic
|
||||
( -- * Re-exports
|
||||
module Export ) where
|
||||
|
||||
import Error.Diagnose.Diagnostic.Internal as Export (Diagnostic, def, printDiagnostic, addFile, addReport)
|
||||
|
||||
import System.IO as Export (stdout, stderr)
|
||||
87
src/Error/Diagnose/Diagnostic/Internal.hs
Normal file
87
src/Error/Diagnose/Diagnostic/Internal.hs
Normal file
@ -0,0 +1,87 @@
|
||||
{-|
|
||||
Module : Error.Diagnose.Diagnostic.Internal
|
||||
Description : Internal workings for diagnostic 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.Diagnostic" module, which exports some of the useful functions defined here.
|
||||
-}
|
||||
module Error.Diagnose.Diagnostic.Internal (module Error.Diagnose.Diagnostic.Internal, def) where
|
||||
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
|
||||
import Data.Default (Default, def)
|
||||
import Data.Foldable (fold)
|
||||
import Data.HashMap.Lazy (HashMap)
|
||||
import Data.List (intersperse)
|
||||
|
||||
import Error.Diagnose.Report
|
||||
import Error.Diagnose.Report.Internal (prettyReport)
|
||||
|
||||
import System.IO (Handle)
|
||||
|
||||
import Text.PrettyPrint.ANSI.Leijen (Pretty, Doc, empty, hardline, hPutDoc, plain)
|
||||
import qualified Data.HashMap.Lazy as HashMap
|
||||
|
||||
|
||||
-- | The data type for diagnostic containing messages of an abstract type.
|
||||
--
|
||||
-- The constructors are private, but users can use 'def' from the 'Default' typeclass
|
||||
-- to create a new empty diagnostic, and 'addFile' and 'addReport' to alter its internal state.
|
||||
data Diagnostic msg
|
||||
= Diagnostic
|
||||
[Report msg] -- ^ All the reports contained in a diagnostic.
|
||||
--
|
||||
-- Reports are output one by one, without connections in between.
|
||||
(HashMap FilePath [String]) -- ^ A map associating files with their content as lists of lines.
|
||||
|
||||
instance Default (Diagnostic msg) where
|
||||
def = Diagnostic mempty mempty
|
||||
|
||||
instance Semigroup (Diagnostic msg) where
|
||||
Diagnostic rs1 file <> Diagnostic rs2 _ = Diagnostic (rs1 <> rs2) file
|
||||
|
||||
|
||||
-- | Pretty prints a diagnostic into a 'Doc'ument that can be output using
|
||||
-- 'Text.PrettyPrint.ANSI.Leijen.hPutDoc' or 'Text.PrettyPrint.ANSI.Leijen.displayIO'.
|
||||
prettyDiagnostic :: Pretty msg
|
||||
=> Bool -- ^ Should we use unicode when printing paths?
|
||||
-> Diagnostic msg -- ^ The diagnostic to print
|
||||
-> Doc
|
||||
prettyDiagnostic withUnicode (Diagnostic reports file) =
|
||||
fold . intersperse hardline $ prettyReport file withUnicode <$> reports
|
||||
{-# INLINE prettyDiagnostic #-}
|
||||
|
||||
-- | Prints a 'Diagnostic' onto a specific 'Handle'.
|
||||
printDiagnostic :: (MonadIO m, Pretty msg)
|
||||
=> Handle -- ^ The handle onto which to output the diagnostic.
|
||||
-> Bool -- ^ Should we print with unicode characters?
|
||||
-> Bool -- ^ 'False' to disable colors.
|
||||
-> Diagnostic msg -- ^ The diagnostic to output.
|
||||
-> m ()
|
||||
printDiagnostic handle withUnicode withColors diag =
|
||||
liftIO $ hPutDoc handle (unlessId withColors plain $ prettyDiagnostic withUnicode diag)
|
||||
where
|
||||
unlessId cond app = if cond then id else app
|
||||
{-# INLINE unlessId #-}
|
||||
{-# INLINE printDiagnostic #-}
|
||||
|
||||
-- | Inserts a new referenceable file within the diagnostic.
|
||||
addFile :: Diagnostic msg
|
||||
-> FilePath -- ^ The path to the file.
|
||||
-> String -- ^ The content of the file as a single string, where lines are ended by @\n@.
|
||||
-> Diagnostic msg
|
||||
addFile (Diagnostic reports files) path content =
|
||||
Diagnostic reports (HashMap.insert path (lines content) files)
|
||||
|
||||
-- | Inserts a new report into a diagnostic.
|
||||
addReport :: Diagnostic msg
|
||||
-> Report msg -- ^ The new report to add to the diagnostic.
|
||||
-> Diagnostic msg
|
||||
addReport (Diagnostic reports files) report =
|
||||
Diagnostic (report : reports) files
|
||||
53
src/Error/Diagnose/Position.hs
Normal file
53
src/Error/Diagnose/Position.hs
Normal file
@ -0,0 +1,53 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
{-|
|
||||
Module : Error.Diagnose.Diagnostic
|
||||
Description : Defines location information as a simple record.
|
||||
Copyright : (c) Mesabloo, 2021
|
||||
License : BSD3
|
||||
Stability : experimental
|
||||
Portability : Portable
|
||||
-}
|
||||
module Error.Diagnose.Position where
|
||||
|
||||
import Data.Default (Default, def)
|
||||
import Data.Hashable (Hashable)
|
||||
|
||||
import GHC.Generics (Generic(..))
|
||||
|
||||
import Text.PrettyPrint.ANSI.Leijen (Pretty(..), text, colon, int)
|
||||
|
||||
|
||||
-- | Contains information about the location about something.
|
||||
--
|
||||
-- It is best used in a datatype like:
|
||||
--
|
||||
-- > data Located a
|
||||
-- > = a :@ Position
|
||||
-- > deriving (Show, Eq, Ord, Functor, Traversable)
|
||||
data Position
|
||||
= Position
|
||||
{
|
||||
-- | The beginning line and column of the span.
|
||||
begin :: (Int, Int)
|
||||
,
|
||||
-- | The end line and column of the span.
|
||||
end :: (Int, Int)
|
||||
,
|
||||
-- | The file this position spans in.
|
||||
file :: FilePath
|
||||
}
|
||||
deriving (Show, Eq, Generic)
|
||||
|
||||
instance Ord Position where
|
||||
Position b1 e1 _ `compare` Position b2 e2 _ = (b1, e1) `compare` (b2, e2)
|
||||
|
||||
instance Pretty Position where
|
||||
pretty (Position (bl, bc) (el, ec) f) = text f <> at <> int bl <> colon <> int bc <> dash <> int el <> colon <> int ec
|
||||
where at = text "@"
|
||||
dash = text "-"
|
||||
|
||||
instance Hashable Position where
|
||||
|
||||
instance Default Position where
|
||||
def = Position (1, 1) (1, 1) "<no-file>"
|
||||
13
src/Error/Diagnose/Report.hs
Normal file
13
src/Error/Diagnose/Report.hs
Normal file
@ -0,0 +1,13 @@
|
||||
{-|
|
||||
Module : Error.Diagnose.Report
|
||||
Description : Report definition and pretty printing
|
||||
Copyright : (c) Mesabloo, 2021
|
||||
License : BSD3
|
||||
Stability : experimental
|
||||
Portability : Portable
|
||||
-}
|
||||
module Error.Diagnose.Report
|
||||
( -- * Re-exports
|
||||
module Export ) where
|
||||
|
||||
import Error.Diagnose.Report.Internal as Export (Report, warn, err, Marker(..))
|
||||
364
src/Error/Diagnose/Report/Internal.hs
Normal file
364
src/Error/Diagnose/Report/Internal.hs
Normal file
@ -0,0 +1,364 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
{-|
|
||||
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
|
||||
|
||||
import Data.Bifunctor (first, second, bimap)
|
||||
import Data.Default (def)
|
||||
import Data.Foldable (fold)
|
||||
import Data.Function (on)
|
||||
import Data.Functor ((<&>))
|
||||
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 Error.Diagnose.Position
|
||||
|
||||
import Text.PrettyPrint.ANSI.Leijen (Pretty, Doc, empty, bold, red, yellow, colon, pretty, hardline, (<+>), text, black, green, fill, dullgreen, width, dullblue, magenta, int, space, align, cyan, char)
|
||||
import Text.PrettyPrint.ANSI.Leijen.Internal (Doc(..))
|
||||
|
||||
|
||||
-- | 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.
|
||||
|
||||
-- | The type of markers with abstract message type, shown under code lines.
|
||||
data Marker msg
|
||||
= -- | A red or yellow marker under source code, marking important parts of the code.
|
||||
This msg
|
||||
| -- | A blue marker symbolizing additional information.
|
||||
Where msg
|
||||
| -- | A magenta marker to report potential fixes.
|
||||
Maybe msg
|
||||
|
||||
instance Eq (Marker msg) where
|
||||
This _ == This _ = True
|
||||
Where _ == Where _ = True
|
||||
Maybe _ == Maybe _ = True
|
||||
_ == _ = False
|
||||
|
||||
instance Ord (Marker msg) where
|
||||
This _ < _ = False
|
||||
Where _ < This _ = True
|
||||
Where _ < _ = False
|
||||
Maybe _ < _ = True
|
||||
|
||||
m1 <= m2 = m1 < m2 || m1 == m2
|
||||
|
||||
|
||||
-- | 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 empty list of hints to add at the end of the report.
|
||||
-> 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
|
||||
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
|
||||
|
||||
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 = bold if isError then red "[error]" else yellow "[warning]"
|
||||
|
||||
maxLineNumberLength = maybe 3 (max 3 . length . show . fst . end . fst) $ List.safeLast sortedMarkers
|
||||
-- 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 <$> HashMap.toList markersPerLine) <> (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 ' ' empty <+> bold (black $ text if withUnicode then "╭─🢒" else "+->") <+> bold (dullgreen reportFile) <> hardline
|
||||
<+> {- (3) -} pipePrefix maxLineNumberLength withUnicode
|
||||
<> {- (4) -} prettyAllLines fileContent withUnicode isError maxLineNumberLength sortedMarkersPerLine multilineMarkers allLineNumbers
|
||||
<> {- (5) -} (if null hints || null markers then empty else hardline <+> dotPrefix maxLineNumberLength withUnicode) <> prettyAllHints hints maxLineNumberLength withUnicode <> hardline
|
||||
<> {- (6) -} bold (black $ pad (maxLineNumberLength + 2) (if withUnicode then '─' else '-') empty <> text if withUnicode then "╯" else "+") <> hardline
|
||||
where
|
||||
isThisMarker (This _) = True
|
||||
isThisMarker _ = False
|
||||
|
||||
|
||||
-------------------------------------------------------------------------------------
|
||||
----- INTERNAL STUFF ----------------------------------------------------------------
|
||||
-------------------------------------------------------------------------------------
|
||||
|
||||
-- | Inserts a given number of character after a 'Doc'ument.
|
||||
pad :: Int -> Char -> Doc -> Doc
|
||||
pad n c d = width d \ w -> text (replicate (n - w) c)
|
||||
|
||||
-- | Creates a "dot"-prefix for a report line where there is no code.
|
||||
--
|
||||
-- Pretty printing yields those results:
|
||||
--
|
||||
-- [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
|
||||
dotPrefix leftLen withUnicode = pad leftLen ' ' empty <+> bold (black $ text if withUnicode then "•" else ":")
|
||||
|
||||
-- | Creates a "pipe"-prefix for a report line where there is no code.
|
||||
--
|
||||
-- Pretty printing yields those results:
|
||||
--
|
||||
-- [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
|
||||
pipePrefix leftLen withUnicode = pad leftLen ' ' empty <+> bold (black $ text if withUnicode then "│" else "|")
|
||||
|
||||
-- | Creates a line-prefix for a report line containing source code
|
||||
--
|
||||
-- Pretty printing yields those results:
|
||||
--
|
||||
-- [with unicode] "@␣␣␣3␣│␣@"
|
||||
-- [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
|
||||
linePrefix leftLen lineNo withUnicode =
|
||||
let lineNoLen = length (show lineNo)
|
||||
in bold $ black $ empty <+> pad (leftLen - lineNoLen) ' ' empty <> int lineNo <+> text if withUnicode then "│" else "|"
|
||||
|
||||
-- |
|
||||
splitMarkersPerLine :: [(Position, Marker msg)] -> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
|
||||
splitMarkersPerLine [] = (mempty, mempty)
|
||||
splitMarkersPerLine (m@(Position{..}, _) : ms) =
|
||||
let (bl, bc) = begin
|
||||
(el, ec) = end
|
||||
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
|
||||
prettyAllLines _ _ _ _ _ [] [] = empty
|
||||
prettyAllLines _ withUnicode isError leftLen _ multiline [] =
|
||||
let colorOfLastMultilineMarker = maybe id (markerColor isError . snd) (List.safeLast multiline)
|
||||
-- take the color of the last multiline marker in case we need to add additional bars
|
||||
|
||||
firstPos = maybe def fst (List.safeHead multiline)
|
||||
-- get the position of the first multiline marker to know when we are done
|
||||
|
||||
prefix = hardline <+> dotPrefix leftLen withUnicode <> space
|
||||
prefixWithBar color = prefix <> color (text if withUnicode then "│ " else "| ")
|
||||
|
||||
showMultilineMarkerMessage (_, marker) isLast = markerColor isError marker $ text (if isLast
|
||||
then if withUnicode then "╰╸ " else "`- "
|
||||
else if withUnicode then "├╸ " else "|- ")
|
||||
<> replaceLinesWith (if isLast then prefix <> text " " else prefixWithBar (markerColor isError marker) <> space) (pretty $ markerMessage marker)
|
||||
|
||||
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)
|
||||
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>
|
||||
|
||||
|
||||
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
|
||||
|
||||
colorOfFirstMultilineMarker = maybe id (markerColor isError . snd) (List.safeHead allMultilineMarkersInLine)
|
||||
-- take the first multiline marker to color the entire line, if there is one
|
||||
|
||||
!additionalPrefix = case allMultilineMarkersInLine of
|
||||
[] -> empty
|
||||
(p@(Position _ (el, _) _), marker) : _ ->
|
||||
let hasPredecessor = el == line || maybe False ((/=) p . fst . fst) (List.safeUncons multiline)
|
||||
in colorOfFirstMultilineMarker (text if | hasPredecessor && withUnicode -> "├"
|
||||
| hasPredecessor -> "|"
|
||||
| withUnicode -> "╭"
|
||||
| otherwise -> "+")
|
||||
<> markerColor isError marker (text if withUnicode then "┤" else ">")
|
||||
<> space
|
||||
|
||||
allMarkersInLine = List.sortOn fst $ allInlineMarkersInLine <> allMultilineMarkersInLine
|
||||
in hardline
|
||||
<> {- (1) -} linePrefix leftLen line withUnicode <+> additionalPrefix <> getLine_ files allMarkersInLine line isError
|
||||
<> {- (2) -} showAllMarkersInLine (not $ null multiline) colorOfFirstMultilineMarker withUnicode isError leftLen allInlineMarkersInLine
|
||||
<> {- (3) -} prettyAllLines files withUnicode isError leftLen inline multiline ls
|
||||
|
||||
-- |
|
||||
getLine_ :: HashMap FilePath [String] -> [(Position, Marker msg)] -> Int -> Bool -> Doc
|
||||
getLine_ files markers line isError = case List.safeIndex (line - 1) =<< (HashMap.!?) files . file . fst =<< List.safeHead markers of
|
||||
Nothing -> text "<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 -> bold . markerColor isError m) . snd) (List.safeLast colorizingMarkers) (char c)
|
||||
-- TODO: color the code where there are markers, still prioritizing right markers over left ones
|
||||
where
|
||||
indexed = goIndexed 1
|
||||
|
||||
goIndexed n [] = []
|
||||
goIndexed n (x : xs) = (n, x) : goIndexed (n + 1) xs
|
||||
|
||||
-- |
|
||||
showAllMarkersInLine :: Pretty msg => Bool -> (Doc -> Doc) -> Bool -> Bool -> Int -> [(Position, Marker msg)] -> Doc
|
||||
showAllMarkersInLine _ _ _ _ _ [] = empty
|
||||
showAllMarkersInLine hasMultilines colorMultilinePrefix withUnicode isError leftLen ms =
|
||||
let maxMarkerColumn = snd $ end $ fst $ List.last $ List.sortOn (snd . end . fst) ms
|
||||
specialPrefix = if hasMultilines then colorMultilinePrefix (text if withUnicode then "│ " else "| ") <> space else empty
|
||||
-- get the maximum end column, so that we know when to stop lookinf for other markers on the same line
|
||||
in hardline <+> dotPrefix leftLen withUnicode <+> (if List.null ms then empty else specialPrefix <> showMarkers 1 maxMarkerColumn <> showMessages specialPrefix ms maxMarkerColumn)
|
||||
where
|
||||
showMarkers n lineLen
|
||||
| n > lineLen = empty -- 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
|
||||
markers ->
|
||||
let (Position{..}, marker) = List.last markers
|
||||
in if snd begin == n
|
||||
then markerColor isError marker (text if withUnicode then "┬" else "^") <> showMarkers (n + 1) lineLen
|
||||
else markerColor isError marker (text 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.safeUnsnoc ms of
|
||||
Nothing -> empty -- no more messages to show
|
||||
Just (pipes, (Position b@(_, bc) _ _, msg)) ->
|
||||
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
|
||||
|
||||
allPreviousPipes = nubbedPipes <&> second \ marker -> markerColor isError marker (text if withUnicode then "│" else "|")
|
||||
|
||||
allColumns n [] = (1, [])
|
||||
allColumns n ms@((Position (_, bc) _ _, col) : ms')
|
||||
| n == bc = bimap (+ 1) (col :) (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 =
|
||||
let (n, docs) = allColumns 1 allPreviousPipes
|
||||
in dotPrefix leftLen withUnicode <+> specialPrefix <> fold docs <> text (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 = lineStart <> markerColor isError msg (text if | withUnicode && hasSuccessor -> "├╸"
|
||||
| withUnicode -> "╰╸"
|
||||
| hasSuccessor -> "|-"
|
||||
| otherwise -> "`-")
|
||||
-- in case there are two labels on the same column, output a pipe instead of an angle
|
||||
<+> markerColor isError msg (replaceLinesWith (hardline <+> lineStart <+> text " ") $ 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 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 (Columns f) = Columns (replaceLinesWith repl . f)
|
||||
replaceLinesWith repl (Nesting f) = Nesting (replaceLinesWith repl . f)
|
||||
replaceLinesWith repl (Color l i c d) = Color l i c (replaceLinesWith repl d)
|
||||
replaceLinesWith repl (Intensify i d) = Intensify i (replaceLinesWith repl d)
|
||||
replaceLinesWith repl (Italicize i d) = Italicize i (replaceLinesWith repl d)
|
||||
replaceLinesWith repl (Underline u d) = Underline u (replaceLinesWith repl d)
|
||||
replaceLinesWith _ (RestoreFormat c d i b u) = RestoreFormat c d i b u
|
||||
|
||||
-- | 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.
|
||||
-> (Doc -> Doc) -- ^ A function used to color a 'Doc'.
|
||||
markerColor isError (This _) = if isError then red else yellow
|
||||
markerColor _ (Where _) = dullblue
|
||||
markerColor _ (Maybe _) = magenta
|
||||
|
||||
-- | Retrieves the message held by a marker.
|
||||
markerMessage :: Marker msg -> msg
|
||||
markerMessage (This m) = m
|
||||
markerMessage (Where m) = m
|
||||
markerMessage (Maybe m) = m
|
||||
|
||||
-- | Pretty prints all hints.
|
||||
prettyAllHints :: Pretty msg => [msg] -> Int -> Bool -> Doc
|
||||
prettyAllHints [] _ _ = empty
|
||||
prettyAllHints (h : hs) leftLen withUnicode =
|
||||
{-
|
||||
A hint is composed of:
|
||||
(1) : Hint: <hint message>
|
||||
-}
|
||||
let prefix = hardline <+> pipePrefix leftLen withUnicode
|
||||
in prefix <+> cyan (bold (text "Hint:") <+> replaceLinesWith (prefix <+> text " ") (pretty h))
|
||||
<> prettyAllHints hs leftLen withUnicode
|
||||
220
test/Spec.hs
Normal file
220
test/Spec.hs
Normal file
@ -0,0 +1,220 @@
|
||||
import Error.Diagnose
|
||||
( printDiagnostic,
|
||||
stdout,
|
||||
err,
|
||||
warn,
|
||||
Marker(..),
|
||||
Diagnostic(..),
|
||||
Report,
|
||||
Position(..),
|
||||
addFile,
|
||||
addReport,
|
||||
def )
|
||||
|
||||
import qualified Data.HashMap.Lazy as HashMap
|
||||
|
||||
import System.IO (hPutStrLn)
|
||||
import Data.List (foldl')
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
let files = 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")
|
||||
]
|
||||
|
||||
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
|
||||
, beautifulExample
|
||||
]
|
||||
|
||||
let diag = HashMap.foldlWithKey' addFile (foldr (flip addReport) def reports) files
|
||||
|
||||
hPutStrLn stdout "\n\nWith unicode: ─────────────────────────\n"
|
||||
printDiagnostic stdout True True diag
|
||||
hPutStrLn stdout "\n\nWithout unicode: ----------------------\n"
|
||||
printDiagnostic stdout False True diag
|
||||
|
||||
errorNoMarkersNoHints :: Report String
|
||||
errorNoMarkersNoHints =
|
||||
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") ]
|
||||
[]
|
||||
|
||||
warningSingleMarkerNoHints :: Report String
|
||||
warningSingleMarkerNoHints =
|
||||
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") ]
|
||||
[]
|
||||
|
||||
errorSingleMarkerOutOfBoundsNoHints :: Report String
|
||||
errorSingleMarkerOutOfBoundsNoHints =
|
||||
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") ]
|
||||
[]
|
||||
|
||||
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") ]
|
||||
[]
|
||||
|
||||
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") ]
|
||||
[]
|
||||
|
||||
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." ]
|
||||
|
||||
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") ]
|
||||
[]
|
||||
|
||||
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") ]
|
||||
[]
|
||||
|
||||
errorWithMultilineErrorNoMarkerNoHints :: Report String
|
||||
errorWithMultilineErrorNoMarkerNoHints =
|
||||
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") ]
|
||||
[]
|
||||
|
||||
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") ]
|
||||
[]
|
||||
|
||||
errorNoMarkersSingleHint :: Report String
|
||||
errorNoMarkersSingleHint =
|
||||
err "Error with no marker and one hint"
|
||||
[]
|
||||
[ "First hint" ]
|
||||
|
||||
errorNoMarkersSingleMultilineHint :: Report String
|
||||
errorNoMarkersSingleMultilineHint =
|
||||
err "Error with no marker and one multiline hint"
|
||||
[]
|
||||
[ "First multi\nline hint" ]
|
||||
|
||||
errorNoMarkersTwoHints :: Report String
|
||||
errorNoMarkersTwoHints =
|
||||
err "Error with no markers and two hints"
|
||||
[]
|
||||
[ "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") ]
|
||||
[]
|
||||
|
||||
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") ]
|
||||
[]
|
||||
|
||||
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") ]
|
||||
[]
|
||||
|
||||
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") ]
|
||||
[]
|
||||
|
||||
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") ]
|
||||
[]
|
||||
|
||||
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") ]
|
||||
[]
|
||||
|
||||
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." ]
|
||||
Loading…
Reference in New Issue
Block a user