]> Git — Sourcephile - haskell/symantic-plaintext.git/blob - src/Symantic/Formatter/Class.hs
build: fix target `upload`
[haskell/symantic-plaintext.git] / src / Symantic / Formatter / Class.hs
1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
2 {-# LANGUAGE UndecidableInstances #-}
3 module Symantic.Formatter.Class
4 ( module Symantic.Formatter.Class
5 , Emptyable(..)
6 , Inferable(..)
7 , ProductFunctor(..)
8 , Repeatable(..)
9 , Voidable(..)
10 , bool
11 , char
12 , int
13 , natural
14 , string
15 ) where
16
17 import Data.Bool hiding (bool)
18 import Data.Char (Char)
19 import Data.Foldable (Foldable)
20 import Data.Function ((.), ($))
21 import Data.Int (Int)
22 import Data.Maybe (Maybe(..))
23 import Data.Ord (Ord(..))
24 import Prelude (fromIntegral, pred)
25 import Data.Traversable (Traversable)
26 import Numeric.Natural (Natural)
27 import qualified Data.Functor as Fct
28 import qualified Data.Foldable as Fold
29 import qualified System.Console.ANSI as ANSI
30 import Symantic.Derive
31 import Symantic.Class
32 ( Emptyable(..)
33 , Inferable(..)
34 , ProductFunctor(..)
35 , Repeatable(..)
36 , Voidable(..)
37 , bool
38 , char
39 , int
40 , natural
41 , string
42 )
43
44 concat ::
45 Emptyable repr => ProductFunctor repr =>
46 Foldable f => f (repr ()) -> repr ()
47 concat = Fold.foldr (.>) empty
48
49 -- * Class 'Repeatable'
50 many :: Repeatable repr => repr a -> repr [a]
51 many = many0
52 some :: Repeatable repr => repr a -> repr [a]
53 some = many1
54
55 -- * Class 'Spaceable'
56 class
57 ( ProductFunctor repr
58 , Emptyable repr
59 ) => Spaceable repr where
60 space :: repr ()
61 -- | @'spaces' ind = 'replicate' ind 'space'@
62 spaces :: Column -> repr ()
63 default space :: FromDerived Spaceable repr => repr ()
64 default spaces :: Column -> repr ()
65 spaces i = replicate (fromIntegral i) space
66 space = liftDerived space
67 -- | @x '<+>' y = x '<>' 'space' '<>' y@
68 (<+>) :: repr a -> repr b -> repr (a,b)
69 x <+> y = x <.> space .> y
70 (+>) :: repr () -> repr a -> repr a
71 x +> y = x .> space .> y
72 (<+) :: repr a -> repr () -> repr a
73 x <+ y = x <. space <. y
74
75 type Column = Natural
76
77 -- * Class 'Newlineable'
78 class Newlineable repr where
79 newline :: repr ()
80 default newline :: FromDerived Newlineable repr => repr ()
81 newline = liftDerived newline
82
83 unlines ::
84 Emptyable repr =>
85 ProductFunctor repr =>
86 Foldable f =>
87 f (repr ()) -> repr ()
88 unlines = Fold.foldr (\x acc -> x.>newline.>acc) empty
89 unlines_ :: Listable repr => repr a -> repr [a]
90 unlines_ = intercalate_ newline
91 -- | @x '</>' y = x '<>' 'newline' '<>' y@
92 (</>) :: ProductFunctor repr => repr a -> repr b -> repr (a,b)
93 x </> y = x <.> newline .> y
94 catV ::
95 ProductFunctor repr =>
96 Emptyable repr =>
97 Foldable f =>
98 f (repr ()) -> repr ()
99 catV = intercalate newline
100 infixr 6 <+>
101 infixr 6 </>
102
103 intercalate ::
104 Foldable f => Emptyable repr =>
105 ProductFunctor repr =>
106 repr () -> f (repr ()) -> repr ()
107 intercalate sep rs
108 | Fold.null rs = empty
109 | otherwise = Fold.foldr1 (\x y -> x.>sep.>y) rs
110
111 replicate ::
112 Emptyable repr => ProductFunctor repr =>
113 Int -> repr () -> repr ()
114 replicate cnt t
115 | cnt <= 0 = empty
116 | otherwise = t .> replicate (pred cnt) t
117
118 between ::
119 ProductFunctor repr =>
120 repr () -> repr () -> repr a -> repr a
121 between o c x = o.>x<.c
122 parens, braces, brackets, angles ::
123 ProductFunctor repr =>
124 Voidable repr =>
125 Inferable Char repr =>
126 repr a -> repr a
127 parens = between (void '(' infer) (void ')' infer)
128 braces = between (void '{' infer) (void '}' infer)
129 brackets = between (void '[' infer) (void ']' infer)
130 angles = between (void '<' infer) (void '>' infer)
131
132 -- * Class 'Decorable'
133 class Decorable repr where
134 bold :: repr a -> repr a
135 underline :: repr a -> repr a
136 italic :: repr a -> repr a
137 default bold :: FromDerived1 Decorable repr => repr a -> repr a
138 default underline :: FromDerived1 Decorable repr => repr a -> repr a
139 default italic :: FromDerived1 Decorable repr => repr a -> repr a
140 bold = liftDerived1 bold
141 underline = liftDerived1 underline
142 italic = liftDerived1 italic
143
144 -- * Class 'Colorable16'
145 class Colorable16 repr where
146 reverse :: repr a -> repr a
147
148 -- Foreground colors
149 -- Dull
150 black :: repr a -> repr a
151 red :: repr a -> repr a
152 green :: repr a -> repr a
153 yellow :: repr a -> repr a
154 blue :: repr a -> repr a
155 magenta :: repr a -> repr a
156 cyan :: repr a -> repr a
157 white :: repr a -> repr a
158
159 -- Vivid
160 blacker :: repr a -> repr a
161 redder :: repr a -> repr a
162 greener :: repr a -> repr a
163 yellower :: repr a -> repr a
164 bluer :: repr a -> repr a
165 magentaer :: repr a -> repr a
166 cyaner :: repr a -> repr a
167 whiter :: repr a -> repr a
168
169 -- Background colors
170 -- Dull
171 onBlack :: repr a -> repr a
172 onRed :: repr a -> repr a
173 onGreen :: repr a -> repr a
174 onYellow :: repr a -> repr a
175 onBlue :: repr a -> repr a
176 onMagenta :: repr a -> repr a
177 onCyan :: repr a -> repr a
178 onWhite :: repr a -> repr a
179
180 -- Vivid
181 onBlacker :: repr a -> repr a
182 onRedder :: repr a -> repr a
183 onGreener :: repr a -> repr a
184 onYellower :: repr a -> repr a
185 onBluer :: repr a -> repr a
186 onMagentaer :: repr a -> repr a
187 onCyaner :: repr a -> repr a
188 onWhiter :: repr a -> repr a
189
190 default reverse :: FromDerived1 Colorable16 repr => repr a -> repr a
191 default black :: FromDerived1 Colorable16 repr => repr a -> repr a
192 default red :: FromDerived1 Colorable16 repr => repr a -> repr a
193 default green :: FromDerived1 Colorable16 repr => repr a -> repr a
194 default yellow :: FromDerived1 Colorable16 repr => repr a -> repr a
195 default blue :: FromDerived1 Colorable16 repr => repr a -> repr a
196 default magenta :: FromDerived1 Colorable16 repr => repr a -> repr a
197 default cyan :: FromDerived1 Colorable16 repr => repr a -> repr a
198 default white :: FromDerived1 Colorable16 repr => repr a -> repr a
199 default blacker :: FromDerived1 Colorable16 repr => repr a -> repr a
200 default redder :: FromDerived1 Colorable16 repr => repr a -> repr a
201 default greener :: FromDerived1 Colorable16 repr => repr a -> repr a
202 default yellower :: FromDerived1 Colorable16 repr => repr a -> repr a
203 default bluer :: FromDerived1 Colorable16 repr => repr a -> repr a
204 default magentaer :: FromDerived1 Colorable16 repr => repr a -> repr a
205 default cyaner :: FromDerived1 Colorable16 repr => repr a -> repr a
206 default whiter :: FromDerived1 Colorable16 repr => repr a -> repr a
207 default onBlack :: FromDerived1 Colorable16 repr => repr a -> repr a
208 default onRed :: FromDerived1 Colorable16 repr => repr a -> repr a
209 default onGreen :: FromDerived1 Colorable16 repr => repr a -> repr a
210 default onYellow :: FromDerived1 Colorable16 repr => repr a -> repr a
211 default onBlue :: FromDerived1 Colorable16 repr => repr a -> repr a
212 default onMagenta :: FromDerived1 Colorable16 repr => repr a -> repr a
213 default onCyan :: FromDerived1 Colorable16 repr => repr a -> repr a
214 default onWhite :: FromDerived1 Colorable16 repr => repr a -> repr a
215 default onBlacker :: FromDerived1 Colorable16 repr => repr a -> repr a
216 default onRedder :: FromDerived1 Colorable16 repr => repr a -> repr a
217 default onGreener :: FromDerived1 Colorable16 repr => repr a -> repr a
218 default onYellower :: FromDerived1 Colorable16 repr => repr a -> repr a
219 default onBluer :: FromDerived1 Colorable16 repr => repr a -> repr a
220 default onMagentaer :: FromDerived1 Colorable16 repr => repr a -> repr a
221 default onCyaner :: FromDerived1 Colorable16 repr => repr a -> repr a
222 default onWhiter :: FromDerived1 Colorable16 repr => repr a -> repr a
223
224 reverse = liftDerived1 reverse
225 black = liftDerived1 black
226 red = liftDerived1 red
227 green = liftDerived1 green
228 yellow = liftDerived1 yellow
229 blue = liftDerived1 blue
230 magenta = liftDerived1 magenta
231 cyan = liftDerived1 cyan
232 white = liftDerived1 white
233 blacker = liftDerived1 blacker
234 redder = liftDerived1 redder
235 greener = liftDerived1 greener
236 yellower = liftDerived1 yellower
237 bluer = liftDerived1 bluer
238 magentaer = liftDerived1 magentaer
239 cyaner = liftDerived1 cyaner
240 whiter = liftDerived1 whiter
241 onBlack = liftDerived1 onBlack
242 onRed = liftDerived1 onRed
243 onGreen = liftDerived1 onGreen
244 onYellow = liftDerived1 onYellow
245 onBlue = liftDerived1 onBlue
246 onMagenta = liftDerived1 onMagenta
247 onCyan = liftDerived1 onCyan
248 onWhite = liftDerived1 onWhite
249 onBlacker = liftDerived1 onBlacker
250 onRedder = liftDerived1 onRedder
251 onGreener = liftDerived1 onGreener
252 onYellower = liftDerived1 onYellower
253 onBluer = liftDerived1 onBluer
254 onMagentaer = liftDerived1 onMagentaer
255 onCyaner = liftDerived1 onCyaner
256 onWhiter = liftDerived1 onWhiter
257
258 type SGR = ANSI.SGR
259
260 -- * Class 'Indentable'
261 class Spaceable repr => Indentable repr where
262 -- | @('align' fmt)@ make @fmt@ uses current 'Column' as 'Indent' level.
263 align :: repr a -> repr a
264 -- | @('setIndent' p ind fmt)@ make @fmt@ uses @ind@ as 'Indent' level.
265 -- Using @p@ as 'Indent' text.
266 setIndent :: repr () -> Indent -> repr a -> repr a
267 -- | @('incrIndent' p ind fmt)@ make @fmt@ uses current 'Indent' plus @ind@ as 'Indent' level.
268 -- Appending @p@ to the current 'Indent' text.
269 incrIndent :: repr () -> Indent -> repr a -> repr a
270 hang :: Indent -> repr a -> repr a
271 hang ind = align . incrIndent (spaces ind) ind
272 -- | @('fill' w fmt)@ write @fmt@,
273 -- then if @fmt@ is not wider than @w@,
274 -- write the difference with 'spaces'.
275 fill :: Width -> repr a -> repr a
276 -- | @('fillOrBreak' w fmt)@ write @fmt@,
277 -- then if @fmt@ is not wider than @w@, write the difference with 'spaces'
278 -- otherwise write a 'newline' indented to the start 'Column' of @fmt@ plus @w@.
279 fillOrBreak :: Width -> repr a -> repr a
280
281 default align :: FromDerived1 Indentable repr => repr a -> repr a
282 default incrIndent :: FromDerived2 Indentable repr => repr () -> Indent -> repr a -> repr a
283 default setIndent :: FromDerived2 Indentable repr => repr () -> Indent -> repr a -> repr a
284 default fill :: FromDerived1 Indentable repr => Width -> repr a -> repr a
285 default fillOrBreak :: FromDerived1 Indentable repr => Width -> repr a -> repr a
286
287 align = liftDerived1 align
288 setIndent p i = liftDerived2 (`setIndent`i) p
289 incrIndent p i = liftDerived2 (`incrIndent`i) p
290 fill = liftDerived1 . fill
291 fillOrBreak = liftDerived1 . fillOrBreak
292
293 type Indent = Column
294 type Width = Natural
295
296 -- * Class 'Listable'
297 class Listable repr where
298 ul :: Traversable f => f (repr ()) -> repr ()
299 ol :: Traversable f => f (repr ()) -> repr ()
300 default ul ::
301 FromDerived Listable repr => Derivable repr =>
302 Traversable f => f (repr ()) -> repr ()
303 default ol ::
304 FromDerived Listable repr => Derivable repr =>
305 Traversable f => f (repr ()) -> repr ()
306 ul xs = liftDerived $ ul $ derive Fct.<$> xs
307 ol xs = liftDerived $ ol $ derive Fct.<$> xs
308 unorderedList :: repr a -> repr [a]
309 orderedList :: repr a -> repr [a]
310 list_ :: repr () -> repr () -> repr () -> repr a -> repr [a]
311 default unorderedList :: FromDerived1 Listable repr => repr a -> repr [a]
312 default orderedList :: FromDerived1 Listable repr => repr a -> repr [a]
313 default list_ :: FromDerived4 Listable repr => repr () -> repr () -> repr () -> repr a -> repr [a]
314 unorderedList = liftDerived1 unorderedList
315 orderedList = liftDerived1 orderedList
316 list_ = liftDerived4 list_
317 intercalate_ :: repr () -> repr a -> repr [a]
318 default intercalate_ ::
319 FromDerived2 Listable repr =>
320 repr () -> repr a -> repr [a]
321 intercalate_ = liftDerived2 intercalate_
322 braceList ::
323 Voidable repr => Inferable Char repr =>
324 repr a -> repr [a]
325 braceList = list_ (void '{' infer) (void ',' infer) (void '}' infer)
326 bracketList ::
327 Voidable repr => Inferable Char repr =>
328 repr a -> repr [a]
329 bracketList = list_ (void '[' infer) (void ',' infer) (void ']' infer)
330 parenList ::
331 Voidable repr => Inferable Char repr =>
332 repr a -> repr [a]
333 parenList = list_ (void '(' infer) (void ',' infer) (void ')' infer)
334 angleList ::
335 Voidable repr => Inferable Char repr =>
336 repr a -> repr [a]
337 angleList = list_ (void '<' infer) (void ',' infer) (void '>' infer)
338
339 -- * Class 'Wrappable'
340 class Wrappable repr where
341 setWidth :: Maybe Width -> repr a -> repr a
342 -- getWidth :: (Maybe Width -> repr a) -> repr a
343 breakpoint :: repr ()
344 breakspace :: repr ()
345 breakalt :: repr a -> repr a -> repr a
346 endline :: repr ()
347 default breakpoint :: FromDerived Wrappable repr => repr ()
348 default breakspace :: FromDerived Wrappable repr => repr ()
349 default breakalt :: FromDerived2 Wrappable repr => repr a -> repr a -> repr a
350 default endline :: FromDerived Wrappable repr => repr ()
351 breakpoint = liftDerived breakpoint
352 breakspace = liftDerived breakspace
353 breakalt = liftDerived2 breakalt
354 endline = liftDerived endline
355 unwords ::
356 ProductFunctor repr =>
357 Listable repr =>
358 Emptyable repr =>
359 Foldable f =>
360 f (repr ()) -> repr ()
361 unwords_ :: Listable repr => repr a -> repr [a]
362 unwords = intercalate breakspace
363 unwords_ = intercalate_ breakspace
364
365 -- * Class 'Justifiable'
366 class Justifiable repr where
367 justify :: repr a -> repr a