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
|
{-# 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
-- | 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
-- | 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
-- | `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
-- TODO Fix spacing between markdown nodes
--
-- The following code suffers from the problem that inline code such as `foo` is not separated correctly when surrounded by non-whitespace characters, ie. `foo`, or `foo`s.
--
-- The reason for that is that we generally trim words within `TEXT` nodes, and then add the spaces back.
--
-- Thus, we should not trim words. But we should still replace whitespace by `P.softline`s (ie. `P.fillSep`) for automatic paragraph wrapping.
--
-- @topic markdown
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) = fillSep $ 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) _) =
fillSep . map (pretty . T.strip) $
T.words 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)
|
