-
Notifications
You must be signed in to change notification settings - Fork 0
/
Notice.hs
102 lines (84 loc) · 2.81 KB
/
Notice.hs
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
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
module Control.Effect.Parser.Notice
( Level(..)
, Notice(..)
, level_
, excerpt_
, reason_
, context_
, Style(..)
, ansiStyle
, prettyNoticeWith
, prettyNotice
) where
import Control.Effect.Parser.Excerpt
import Control.Effect.Parser.Lens
import Control.Effect.Parser.Source
import Control.Effect.Parser.Span as Span
import Data.Maybe (fromMaybe)
import Prettyprinter
import Prettyprinter.Render.Terminal (AnsiStyle, Color(..), bold, color)
data Level
= Warn
| Error
deriving (Eq, Ord, Show)
instance Pretty Level where
pretty = \case
Warn -> pretty "warning"
Error -> pretty "error"
data Notice a = Notice
{ level :: !(Maybe Level)
, excerpt :: {-# UNPACK #-} !Excerpt
, reason :: !(Doc a)
, context :: ![Doc a]
}
deriving (Show)
level_ :: Lens' (Notice a) (Maybe Level)
level_ = lens level $ \ n level -> n{ level }
excerpt_ :: Lens' (Notice a) Excerpt
excerpt_ = lens excerpt $ \ n excerpt -> n{ excerpt }
reason_ :: Lens' (Notice a) (Doc a)
reason_ = lens reason $ \ n reason -> n{ reason }
context_ :: Lens' (Notice a) [Doc a]
context_ = lens context $ \ n context -> n{ context }
data Style a = Style
{ pathStyle :: a
, levelStyle :: Level -> a
, posStyle :: a
, gutterStyle :: a
, eofStyle :: a
, caretStyle :: a
}
ansiStyle :: Style AnsiStyle
ansiStyle = Style
{ pathStyle = bold
, levelStyle = \case
Warn -> color Magenta
Error -> color Red
, posStyle = bold
, gutterStyle = color Blue
, eofStyle = color Blue
, caretStyle = color Green
}
prettyNoticeWith :: Style a -> Notice a -> Doc a
prettyNoticeWith Style{ pathStyle, levelStyle, posStyle, gutterStyle, eofStyle, caretStyle } (Notice level (Excerpt path line span) reason context) = vsep
( nest 2 (group (fillSep
[ annotate pathStyle (pretty (fromMaybe "(interactive)" path)) <> colon <> pos (Span.start span) <> colon <> foldMap ((space <>) . (<> colon) . (annotate . levelStyle <*> pretty)) level
, reason
]))
: annotate gutterStyle (pretty (succ (Span.line (Span.start span)))) <+> align (vcat
[ annotate gutterStyle (pretty '|') <+> prettyLineWith line
, annotate gutterStyle (pretty '|') <+> padding span <> caret span
])
: context)
where
pos (Pos l c) = annotate posStyle (pretty (succ l)) <> colon <> annotate posStyle (pretty (succ c))
padding (Span (Pos _ c) _) = pretty (replicate c ' ')
caret (Span start@(Pos sl sc) end@(Pos el ec))
| start == end = annotate caretStyle (pretty '^')
| sl == el = annotate caretStyle (pretty (replicate (ec - sc) '~'))
| otherwise = annotate caretStyle (pretty "^…")
prettyLineWith (Line line end) = pretty line <> annotate eofStyle (pretty end)
prettyNotice :: Notice AnsiStyle -> Doc AnsiStyle
prettyNotice = prettyNoticeWith ansiStyle