1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
|
module HSVIS.Diagnostic where
import Data.List (intercalate)
import HSVIS.Pretty
data Pos = Pos
{ posLine :: Int -- ^ zero-based
, posCol :: Int -- ^ zero-based
}
deriving (Show, Eq, Ord)
instance Pretty Pos where
prettysPrec _ (Pos y x) = showString (show (y + 1) ++ ":" ++ show (x + 1))
-- | Inclusive-exclusive range of positions in a file.
data Range = Range Pos Pos
deriving (Show)
instance Semigroup Range where
Range a b <> Range c d = Range (min a c) (max b d)
instance Pretty Range where
prettysPrec _ (Range (Pos y1 x1) (Pos y2 x2))
| y2 <= y1 + 1, x2 <= x1 + 1 = showString (show (y1 + 1) ++ ":" ++ show (x1 + 1))
| y2 <= y1 + 1 = showString (show (y1 + 1) ++ ":" ++ show (x1 + 1) ++ "-" ++ show x2)
| otherwise =
showString ("(" ++ show (y1 + 1) ++ ":" ++ show (x1 + 1) ++ ")-(" ++ show (y2 + 1) ++ ":" ++ show x2 ++ ")")
data Severity = SError | SWarning
deriving (Show)
data Diagnostic = Diagnostic
{ dSeverity :: Severity -- ^ Error level
, dFile :: FilePath -- ^ The file for which the diagnostic was raised
, dRange :: Range -- ^ Where in the file
, dStk :: [String] -- ^ Stack of contexts (innermost at head) of the diagnostic
, dSourceLine :: String -- ^ The line in the source file of the start of the range
, dMsg :: String -- ^ The error message
}
deriving (Show)
printDiagnostic :: Diagnostic -> String
printDiagnostic (Diagnostic sev fp rng@(Range (Pos y1 x1) (Pos y2 x2)) stk srcline msg) =
let linenum = show (y1 + 1)
locstr = pretty rng
ncarets | y1 == y2 = max 1 (x2 - x1)
| otherwise = length srcline - x1
caretsuffix | y1 == y2 = ""
| otherwise = "..."
mainLine =
(case sev of SError -> "Error: "
SWarning -> "Warning: ")
++ fp ++ ":" ++ locstr ++ ": " ++ msg
revCtxTrace = reverse $ map (\(i, descr) -> "in " ++ descr ++ (if i == 0 then "" else ","))
(zip [0::Int ..] (reverse stk))
srcPointer =
[map (\_ -> ' ') linenum ++ " |"
,linenum ++ " | " ++ srcline
,map (\_ -> ' ') linenum ++ " | " ++ replicate x1 ' ' ++
replicate ncarets '^' ++ caretsuffix]
in intercalate "\n" $ [mainLine] ++ srcPointer ++ revCtxTrace
|
