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
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
|
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE UndecidableInstances #-}
-- | This module is an experimental wrapper around the prettyprinter module.
module Render
( -- * Re-exports
module Prettyprinter,
module Prettyprinter.Render.Terminal,
-- * Render
Render (..),
(<<<),
(===),
styled,
-- * Reporting styles
Detailed (..),
Summarized (..),
Linked (..),
-- * Markdown
Markdown (..),
renderAsMarkdown,
-- * Additional symbols
plus,
minus,
)
where
import CMark qualified as D
import Data.List (intersperse, isPrefixOf, isSuffixOf)
import Data.Maybe (catMaybes)
import Data.Text qualified as T
import Data.Time.Calendar (Day)
import Prettyprinter
import Prettyprinter.Render.Terminal
import System.IO.Unsafe (unsafePerformIO)
-- | The render class is a superclass of `Pretty`. It exists to facilitate
-- reporting styles (see below), as well as decomposing aggregate entities into composable parts (for instance `IssueTitle`, `IssueTags` of `Issue`).
--
-- Renderable entities are expected to define `Render (Detailed a)` and default `Render a` to that instance.
class Render a where
render :: a -> Doc AnsiStyle
default render :: Pretty a => a -> Doc AnsiStyle
render = pretty
instance Render (Doc AnsiStyle) where
render = id
instance Render T.Text
instance Render String
instance Render Day where
render = render . show
-- TODO Resolve `performUnsafeIO`
--
-- We want `Renderable a => IO a` in our data structures so that we can defer potentially expensive computation until it is actually required to be rendered.
--
-- We should be able to eliminate `unsafePerformIO` by lifting `render` to `a -> IO (Doc AnsiStyle)`.
--
-- @backlog
instance Render a => Render (IO a) where
render = render . unsafePerformIO
-- | The `(<<<)` combinator concatenates renderables. It takes care of inserting spaces between non-empty renderables automatically, obsoleting prettyprinter's `(<+>)` and `(<>)`.
(<<<) :: (Render a, Render b) => a -> b -> Doc AnsiStyle
(<<<) a' b' =
case (nonEmpty a', nonEmpty b') of
(Nothing, Nothing) -> emptyDoc
(Just a, Nothing) -> a
(Nothing, Just b) -> b
(Just a, Just b) ->
if endsWithNL a || startsWithNL b
then a <> b
else a <> space <> b
where
nonEmpty x' =
let x = render x'
in if not (null (show x)) then Just (render x) else Nothing
startsWithNL = ("\n" `isPrefixOf`) . show . render
endsWithNL = ("\n" `isSuffixOf`) . show . render
(===) :: (Render a, Render b) => a -> b -> Doc AnsiStyle
(===) a' b' =
case (nonEmpty a', nonEmpty b') of
(Nothing, Nothing) -> emptyDoc
(Just a, Nothing) -> a
(Nothing, Just b) -> b
(Just a, Just b) ->
if
| endsWithNL a && startsWithNL b -> a <> b
| endsWithNL a || startsWithNL b -> a <> hardline <> b
| otherwise -> a <> hardline <> hardline <> b
where
nonEmpty x' =
let x = render x'
in if not (null (show x)) then Just (render x) else Nothing
startsWithNL = ("\n" `isPrefixOf`) . show . render
endsWithNL = ("\n" `isSuffixOf`) . show . render
-- | `styled` allows to annotate a document with multiple annotations. It obsoletes prettyprinter's `annotate`.
styled :: [AnsiStyle] -> Doc AnsiStyle -> Doc AnsiStyle
styled [] doc = doc
styled as doc = foldl1 (.) (map annotate as) $ doc
-- | The detailed report should present all information, corresponding to the semantics of the `show` command.
--
-- It should be the default instance for all data types.
newtype Detailed a = Detailed {unDetailed :: a}
-- | The summarized report should present most relevant information in a concise way, corresponding to the semantics of the `list` command.
newtype Summarized a = Summarized {unSummarized :: a}
-- | The linked report should present strictly necessary information. It should be used when one entity refers to another.
newtype Linked a = Linked {unLinked :: a}
newtype Markdown = Markdown {unMarkdown :: D.Node}
renderAsMarkdown :: T.Text -> Doc AnsiStyle
renderAsMarkdown = render . Markdown . D.commonmarkToNode []
instance Render Markdown where
render = render . unMarkdown
instance Render [D.Node] where
render = render . D.Node Nothing D.DOCUMENT
instance Render D.Node where
render = maybe emptyDoc go . rec
where
rec (D.Node _ D.SOFTBREAK _) = Nothing
rec (D.Node p t ns) = Just $ D.Node p t (catMaybes $ map rec ns)
go (D.Node _ D.DOCUMENT ns) = vsep (intersperse (pretty ("" :: T.Text)) (map go ns))
go (D.Node _ D.THEMATIC_BREAK _) = pretty ("***" :: T.Text)
go (D.Node _ D.PARAGRAPH ns) = hcat $ map go ns
go (D.Node _ D.BLOCK_QUOTE ns) =
styled [color Black] . fillSep $
pretty (">" :: T.Text)
: [ align . fillSep $
map go ns
++ [pretty ("\n" :: T.Text)]
]
go (D.Node _ (D.HTML_BLOCK s) _) =
styled [color Yellow] $
hsep
[ pretty (T.strip s),
pretty ("\n" :: T.Text)
]
go (D.Node _ (D.CUSTOM_BLOCK _ _) ns) =
styled [color Yellow] $
hsep $
map go ns ++ [pretty ("\n" :: T.Text)]
go (D.Node _ (D.CODE_BLOCK _ s) _) =
hcat
[ styled [color Green] (pretty ("────────────────────\n" :: T.Text)),
styled [color Yellow]
. vsep
. map (styled [color Yellow] . pretty)
$ T.lines s,
pretty ("\n" :: T.Text),
styled [color Green] (pretty ("────────────────────" :: T.Text))
]
go (D.Node _ (D.HEADING c) ns) =
styled [color Magenta] . fillSep $
pretty (T.replicate c "#") : map go ns
go (D.Node _ (D.LIST _) ns) =
hsep (map ((pretty ("- " :: T.Text)) <>) (map go ns))
go (D.Node _ D.ITEM ns) = fillSep (map go ns)
go (D.Node _ (D.TEXT s) _) =
hcat
. intersperse softline
. map pretty
. ( \xs ->
-- first and last `T.null`-elements must be preserved as it may represents whitespace between sibling `D.Node`s.
if length xs >= 2
then
head xs
: filter (not . T.null) (tail . init $ xs)
++ [last xs]
else xs
)
. T.split (== ' ')
$ s
go (D.Node _ D.LINEBREAK _) = hardline
go (D.Node _ (D.HTML_INLINE s) _) =
styled [color Yellow] $ pretty (T.strip s)
go (D.Node _ (D.CUSTOM_INLINE _ _) ns) =
styled [color Yellow] . fillSep $ map go ns
go (D.Node _ (D.CODE s) _) =
styled [color Yellow] $ pretty (T.strip s)
go (D.Node _ D.EMPH ns) = styled [italicized] $ fillSep (map go ns)
go (D.Node _ D.STRONG ns) = styled [bold] $ fillSep (map go ns)
go (D.Node _ D.SOFTBREAK _) = emptyDoc
go (D.Node _ (D.LINK url "") ns) =
styled [color Blue] $
hcat
[ pretty ("[" :: T.Text),
hsep (map go ns),
pretty ("](" :: T.Text),
pretty url,
pretty (")" :: T.Text)
]
go (D.Node _ (D.LINK url title) ns) =
styled [color Blue] $
hcat
[ pretty ("[" :: T.Text),
hsep (map go ns),
pretty ("](" :: T.Text),
pretty url,
pretty (" \"" :: T.Text),
pretty title,
pretty ("\")" :: T.Text)
]
go (D.Node _ (D.IMAGE url "") ns) =
styled [color Blue] $
hcat
[ pretty ("![" :: T.Text),
hsep (map go ns),
pretty ("](" :: T.Text),
pretty url,
pretty (")" :: T.Text)
]
go (D.Node _ (D.IMAGE url title) ns) =
styled [color Blue] $
hcat
[ pretty ("![" :: T.Text),
hsep (map go ns),
pretty ("](" :: T.Text),
pretty url,
pretty (" \"" :: T.Text),
pretty title,
pretty ("\")" :: T.Text)
]
plus :: Doc ann
plus = pretty ("+" :: T.Text)
minus :: Doc ann
minus = pretty ("-" :: T.Text)
|
