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