]> Git — Sourcephile - haskell/symantic-document.git/blob - src/Symantic/Document/Class.hs
impl: cleanup tabs
[haskell/symantic-document.git] / src / Symantic / Document / Class.hs
1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
2 {-# LANGUAGE UndecidableInstances #-}
3 module Symantic.Document.Class where
4
5 import Control.Applicative (Applicative(..))
6 import Data.Bool
7 import Data.Char (Char)
8 import Data.Eq (Eq(..))
9 import Data.Foldable (Foldable)
10 import Data.Function ((.), ($), id, const)
11 import Data.Functor (Functor(..), (<$>))
12 import Data.Int (Int)
13 import Data.Kind (Type)
14 import Data.Maybe (Maybe(..))
15 import Data.Monoid (Monoid(..))
16 import Data.Ord (Ord(..))
17 import Data.Semigroup (Semigroup(..))
18 import Data.String (String, IsString(..))
19 import Data.Text (Text)
20 import Data.Traversable (Traversable)
21 import Numeric.Natural (Natural)
22 import Prelude (Integer, fromIntegral, pred)
23 import Text.Show (Show(..))
24 import qualified Data.Foldable as Fold
25 import qualified Data.List as List
26 import qualified Data.Text as Text
27 import qualified Data.Text.Lazy as TL
28 import qualified Data.Text.Lazy.Builder as TLB
29 import qualified System.Console.ANSI as ANSI
30
31 -- * Helper types
32 type Column = Natural
33 type Indent = Column
34 type Width = Natural
35 type SGR = ANSI.SGR
36
37 -- ** Type 'Line'
38 newtype Line d = Line d
39 deriving (Eq,Show)
40 unLine :: Line d -> d
41 unLine (Line d) = d
42
43 -- ** Type 'Word'
44 newtype Word d = Word d
45 deriving (Eq,Show,Semigroup)
46 unWord :: Word d -> d
47 unWord (Word d) = d
48 instance From [SGR] d => From [SGR] (Word d) where
49 from = Word . from
50
51 -- * Class 'From'
52 class From a d where
53 from :: a -> d
54 default from :: From String d => Show a => a -> d
55 from = from . show
56 instance From (Line String) d => From Int d where
57 from = from . Line . show
58 instance From (Line String) d => From Integer d where
59 from = from . Line . show
60 instance From (Line String) d => From Natural d where
61 from = from . Line . show
62
63 -- String
64 instance From Char String where
65 from = pure
66 instance From String String where
67 from = id
68 instance From Text String where
69 from = Text.unpack
70 instance From TL.Text String where
71 from = TL.unpack
72 instance From d String => From (Line d) String where
73 from = from . unLine
74 instance From d String => From (Word d) String where
75 from = from . unWord
76 instance From [SGR] String where
77 from = ANSI.setSGRCode
78
79 -- Text
80 instance From Char Text where
81 from = Text.singleton
82 instance From String Text where
83 from = Text.pack
84 instance From Text Text where
85 from = id
86 instance From TL.Text Text where
87 from = TL.toStrict
88 instance From d Text => From (Line d) Text where
89 from = from . unLine
90 instance From d Text => From (Word d) Text where
91 from = from . unWord
92 instance From [SGR] Text where
93 from = from . ANSI.setSGRCode
94
95 -- TL.Text
96 instance From Char TL.Text where
97 from = TL.singleton
98 instance From String TL.Text where
99 from = TL.pack
100 instance From Text TL.Text where
101 from = TL.fromStrict
102 instance From TL.Text TL.Text where
103 from = id
104 instance From d TL.Text => From (Line d) TL.Text where
105 from = from . unLine
106 instance From d TL.Text => From (Word d) TL.Text where
107 from = from . unWord
108 instance From [SGR] TL.Text where
109 from = from . ANSI.setSGRCode
110
111 -- TLB.Builder
112 instance From Char TLB.Builder where
113 from = TLB.singleton
114 instance From String TLB.Builder where
115 from = fromString
116 instance From Text TLB.Builder where
117 from = TLB.fromText
118 instance From TL.Text TLB.Builder where
119 from = TLB.fromLazyText
120 instance From TLB.Builder TLB.Builder where
121 from = id
122 instance From d TLB.Builder => From (Line d) TLB.Builder where
123 from = from . unLine
124 instance From d TLB.Builder => From (Word d) TLB.Builder where
125 from = from . unWord
126 instance From [SGR] TLB.Builder where
127 from = from . ANSI.setSGRCode
128
129 runTextBuilder :: TLB.Builder -> TL.Text
130 runTextBuilder = TLB.toLazyText
131
132 -- * Class 'Lengthable'
133 class Lengthable d where
134 width :: d -> Column
135 nullWidth :: d -> Bool
136 nullWidth d = width d == 0
137 instance Lengthable Char where
138 width _ = 1
139 nullWidth = const False
140 instance Lengthable String where
141 width = fromIntegral . List.length
142 nullWidth = Fold.null
143 instance Lengthable Text.Text where
144 width = fromIntegral . Text.length
145 nullWidth = Text.null
146 instance Lengthable TL.Text where
147 width = fromIntegral . TL.length
148 nullWidth = TL.null
149 instance Lengthable d => Lengthable (Line d) where
150 width = fromIntegral . width . unLine
151 nullWidth = nullWidth . unLine
152 instance Lengthable d => Lengthable (Word d) where
153 width = fromIntegral . width . unWord
154 nullWidth = nullWidth . unWord
155
156 -- * Class 'Spaceable'
157 class Monoid d => Spaceable d where
158 newline :: d
159 space :: d
160 default newline :: Spaceable (UnTrans d) => Trans d => d
161 default space :: Spaceable (UnTrans d) => Trans d => d
162 newline = noTrans newline
163 space = noTrans space
164
165 -- | @'spaces' ind = 'replicate' ind 'space'@
166 spaces :: Column -> d
167 default spaces :: Monoid d => Column -> d
168 spaces i = replicate (fromIntegral i) space
169 unlines :: Foldable f => f (Line d) -> d
170 unlines = Fold.foldr (\(Line x) acc -> x<>newline<>acc) mempty
171 unwords :: Foldable f => Functor f => f (Word d) -> d
172 unwords = intercalate space . (unWord <$>)
173 -- | Like 'unlines' but without the trailing 'newline'.
174 catLines :: Foldable f => Functor f => f (Line d) -> d
175 catLines = catV . (unLine <$>)
176 -- | @x '<+>' y = x '<>' 'space' '<>' y@
177 (<+>) :: d -> d -> d
178 -- | @x '</>' y = x '<>' 'newline' '<>' y@
179 (</>) :: d -> d -> d
180 x <+> y = x <> space <> y
181 x </> y = x <> newline <> y
182 catH :: Foldable f => f d -> d
183 catV :: Foldable f => f d -> d
184 catH = Fold.foldr (<>) mempty
185 catV = intercalate newline
186 infixr 6 <+>
187 infixr 6 </>
188 instance Spaceable String where
189 newline = "\n"
190 space = " "
191 spaces n = List.replicate (fromIntegral n) ' '
192 instance Spaceable Text where
193 newline = "\n"
194 space = " "
195 spaces n = Text.replicate (fromIntegral n) " "
196 instance Spaceable TL.Text where
197 newline = "\n"
198 space = " "
199 spaces n = TL.replicate (fromIntegral n) " "
200 instance Spaceable TLB.Builder where
201 newline = TLB.singleton '\n'
202 space = TLB.singleton ' '
203 spaces = TLB.fromText . spaces
204
205 intercalate :: (Foldable f, Monoid d) => d -> f d -> d
206 intercalate sep ds = if Fold.null ds then mempty else Fold.foldr1 (\x y -> x<>sep<>y) ds
207
208 replicate :: Monoid d => Int -> d -> d
209 replicate cnt t | cnt <= 0 = mempty
210 | otherwise = t `mappend` replicate (pred cnt) t
211
212 between :: Semigroup d => d -> d -> d -> d
213 between o c d = o<>d<>c
214 parens :: Semigroup d => From (Word Char) d => d -> d
215 parens = between (from (Word '(')) (from (Word ')'))
216 braces :: Semigroup d => From (Word Char) d => d -> d
217 braces = between (from (Word '{')) (from (Word '}'))
218 brackets :: Semigroup d => From (Word Char) d => d -> d
219 brackets = between (from (Word '[')) (from (Word ']'))
220 angles :: Semigroup d => From (Word Char) d => d -> d
221 angles = between (from (Word '<')) (from (Word '>'))
222
223 -- * Class 'Splitable'
224 class (Lengthable d, Monoid d) => Splitable d where
225 tail :: d -> Maybe d
226 break :: (Char -> Bool) -> d -> (d, d)
227 span :: (Char -> Bool) -> d -> (d, d)
228 span f = break (not . f)
229 lines :: d -> [Line d]
230 words :: d -> [Word d]
231 linesNoEmpty :: d -> [Line d]
232 wordsNoEmpty :: d -> [Word d]
233 lines = (Line <$>) . splitOnChar (== '\n')
234 words = (Word <$>) . splitOnChar (== ' ')
235 linesNoEmpty = (Line <$>) . splitOnCharNoEmpty (== '\n')
236 wordsNoEmpty = (Word <$>) . splitOnCharNoEmpty (== ' ')
237
238 splitOnChar :: (Char -> Bool) -> d -> [d]
239 splitOnChar f d0 =
240 if nullWidth d0 then [] else go d0
241 where
242 go d =
243 let (l,r) = f`break`d in
244 l : case tail r of
245 Nothing -> []
246 Just rt | nullWidth rt -> [mempty]
247 | otherwise -> go rt
248 splitOnCharNoEmpty :: (Char -> Bool) -> d -> [d]
249 splitOnCharNoEmpty f d =
250 let (l,r) = f`break`d in
251 (if nullWidth l then [] else [l]) <>
252 case tail r of
253 Nothing -> []
254 Just rt -> splitOnCharNoEmpty f rt
255 instance Splitable String where
256 tail [] = Nothing
257 tail s = Just $ List.tail s
258 break = List.break
259 instance Splitable Text.Text where
260 tail "" = Nothing
261 tail s = Just $ Text.tail s
262 break = Text.break
263 instance Splitable TL.Text where
264 tail "" = Nothing
265 tail s = Just $ TL.tail s
266 break = TL.break
267
268 -- * Class 'Decorable'
269 class Decorable d where
270 bold :: d -> d
271 underline :: d -> d
272 italic :: d -> d
273 default bold :: Decorable (UnTrans d) => Trans d => d -> d
274 default underline :: Decorable (UnTrans d) => Trans d => d -> d
275 default italic :: Decorable (UnTrans d) => Trans d => d -> d
276 bold = noTrans1 bold
277 underline = noTrans1 underline
278 italic = noTrans1 italic
279
280 -- * Class 'Colorable16'
281 class Colorable16 d where
282 reverse :: d -> d
283
284 -- Foreground colors
285 -- Dull
286 black :: d -> d
287 red :: d -> d
288 green :: d -> d
289 yellow :: d -> d
290 blue :: d -> d
291 magenta :: d -> d
292 cyan :: d -> d
293 white :: d -> d
294
295 -- Vivid
296 blacker :: d -> d
297 redder :: d -> d
298 greener :: d -> d
299 yellower :: d -> d
300 bluer :: d -> d
301 magentaer :: d -> d
302 cyaner :: d -> d
303 whiter :: d -> d
304
305 -- Background colors
306 -- Dull
307 onBlack :: d -> d
308 onRed :: d -> d
309 onGreen :: d -> d
310 onYellow :: d -> d
311 onBlue :: d -> d
312 onMagenta :: d -> d
313 onCyan :: d -> d
314 onWhite :: d -> d
315
316 -- Vivid
317 onBlacker :: d -> d
318 onRedder :: d -> d
319 onGreener :: d -> d
320 onYellower :: d -> d
321 onBluer :: d -> d
322 onMagentaer :: d -> d
323 onCyaner :: d -> d
324 onWhiter :: d -> d
325
326 default reverse :: Colorable16 (UnTrans d) => Trans d => d -> d
327 default black :: Colorable16 (UnTrans d) => Trans d => d -> d
328 default red :: Colorable16 (UnTrans d) => Trans d => d -> d
329 default green :: Colorable16 (UnTrans d) => Trans d => d -> d
330 default yellow :: Colorable16 (UnTrans d) => Trans d => d -> d
331 default blue :: Colorable16 (UnTrans d) => Trans d => d -> d
332 default magenta :: Colorable16 (UnTrans d) => Trans d => d -> d
333 default cyan :: Colorable16 (UnTrans d) => Trans d => d -> d
334 default white :: Colorable16 (UnTrans d) => Trans d => d -> d
335 default blacker :: Colorable16 (UnTrans d) => Trans d => d -> d
336 default redder :: Colorable16 (UnTrans d) => Trans d => d -> d
337 default greener :: Colorable16 (UnTrans d) => Trans d => d -> d
338 default yellower :: Colorable16 (UnTrans d) => Trans d => d -> d
339 default bluer :: Colorable16 (UnTrans d) => Trans d => d -> d
340 default magentaer :: Colorable16 (UnTrans d) => Trans d => d -> d
341 default cyaner :: Colorable16 (UnTrans d) => Trans d => d -> d
342 default whiter :: Colorable16 (UnTrans d) => Trans d => d -> d
343 default onBlack :: Colorable16 (UnTrans d) => Trans d => d -> d
344 default onRed :: Colorable16 (UnTrans d) => Trans d => d -> d
345 default onGreen :: Colorable16 (UnTrans d) => Trans d => d -> d
346 default onYellow :: Colorable16 (UnTrans d) => Trans d => d -> d
347 default onBlue :: Colorable16 (UnTrans d) => Trans d => d -> d
348 default onMagenta :: Colorable16 (UnTrans d) => Trans d => d -> d
349 default onCyan :: Colorable16 (UnTrans d) => Trans d => d -> d
350 default onWhite :: Colorable16 (UnTrans d) => Trans d => d -> d
351 default onBlacker :: Colorable16 (UnTrans d) => Trans d => d -> d
352 default onRedder :: Colorable16 (UnTrans d) => Trans d => d -> d
353 default onGreener :: Colorable16 (UnTrans d) => Trans d => d -> d
354 default onYellower :: Colorable16 (UnTrans d) => Trans d => d -> d
355 default onBluer :: Colorable16 (UnTrans d) => Trans d => d -> d
356 default onMagentaer :: Colorable16 (UnTrans d) => Trans d => d -> d
357 default onCyaner :: Colorable16 (UnTrans d) => Trans d => d -> d
358 default onWhiter :: Colorable16 (UnTrans d) => Trans d => d -> d
359
360 reverse = noTrans1 reverse
361 black = noTrans1 black
362 red = noTrans1 red
363 green = noTrans1 green
364 yellow = noTrans1 yellow
365 blue = noTrans1 blue
366 magenta = noTrans1 magenta
367 cyan = noTrans1 cyan
368 white = noTrans1 white
369 blacker = noTrans1 blacker
370 redder = noTrans1 redder
371 greener = noTrans1 greener
372 yellower = noTrans1 yellower
373 bluer = noTrans1 bluer
374 magentaer = noTrans1 magentaer
375 cyaner = noTrans1 cyaner
376 whiter = noTrans1 whiter
377 onBlack = noTrans1 onBlack
378 onRed = noTrans1 onRed
379 onGreen = noTrans1 onGreen
380 onYellow = noTrans1 onYellow
381 onBlue = noTrans1 onBlue
382 onMagenta = noTrans1 onMagenta
383 onCyan = noTrans1 onCyan
384 onWhite = noTrans1 onWhite
385 onBlacker = noTrans1 onBlacker
386 onRedder = noTrans1 onRedder
387 onGreener = noTrans1 onGreener
388 onYellower = noTrans1 onYellower
389 onBluer = noTrans1 onBluer
390 onMagentaer = noTrans1 onMagentaer
391 onCyaner = noTrans1 onCyaner
392 onWhiter = noTrans1 onWhiter
393
394 -- | For debugging purposes.
395 instance Colorable16 String where
396 reverse = xmlSGR "reverse"
397 black = xmlSGR "black"
398 red = xmlSGR "red"
399 green = xmlSGR "green"
400 yellow = xmlSGR "yellow"
401 blue = xmlSGR "blue"
402 magenta = xmlSGR "magenta"
403 cyan = xmlSGR "cyan"
404 white = xmlSGR "white"
405 blacker = xmlSGR "blacker"
406 redder = xmlSGR "redder"
407 greener = xmlSGR "greener"
408 yellower = xmlSGR "yellower"
409 bluer = xmlSGR "bluer"
410 magentaer = xmlSGR "magentaer"
411 cyaner = xmlSGR "cyaner"
412 whiter = xmlSGR "whiter"
413 onBlack = xmlSGR "onBlack"
414 onRed = xmlSGR "onRed"
415 onGreen = xmlSGR "onGreen"
416 onYellow = xmlSGR "onYellow"
417 onBlue = xmlSGR "onBlue"
418 onMagenta = xmlSGR "onMagenta"
419 onCyan = xmlSGR "onCyan"
420 onWhite = xmlSGR "onWhite"
421 onBlacker = xmlSGR "onBlacker"
422 onRedder = xmlSGR "onRedder"
423 onGreener = xmlSGR "onGreener"
424 onYellower = xmlSGR "onYellower"
425 onBluer = xmlSGR "onBluer"
426 onMagentaer = xmlSGR "onMagentaer"
427 onCyaner = xmlSGR "onCyaner"
428 onWhiter = xmlSGR "onWhiter"
429
430 -- | For debugging purposes.
431 xmlSGR :: Semigroup d => From String d => String -> d -> d
432 xmlSGR newSGR s = from ("<"<>newSGR<>">")<>s<>from ("</"<>newSGR<>">")
433
434 -- * Class 'Indentable'
435 class Spaceable d => Indentable d where
436 -- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.
437 align :: d -> d
438 -- | @('setIndent' p ind d)@ make @d@ uses @ind@ as 'Indent' level.
439 -- Using @p@ as 'Indent' text.
440 setIndent :: d -> Indent -> d -> d
441 -- | @('incrIndent' p ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
442 -- Appending @p@ to the current 'Indent' text.
443 incrIndent :: d -> Indent -> d -> d
444 hang :: Indent -> d -> d
445 hang ind = align . incrIndent (spaces ind) ind
446 -- | @('fill' w d)@ write @d@,
447 -- then if @d@ is not wider than @w@,
448 -- write the difference with 'spaces'.
449 fill :: Width -> d -> d
450 -- | @('fillOrBreak' w d)@ write @d@,
451 -- then if @d@ is not wider than @w@, write the difference with 'spaces'
452 -- otherwise write a 'newline' indented to to the start 'Column' of @d@ plus @w@.
453 fillOrBreak :: Width -> d -> d
454
455 default align :: Indentable (UnTrans d) => Trans d => d -> d
456 default incrIndent :: Indentable (UnTrans d) => Trans d => d -> Indent -> d -> d
457 default setIndent :: Indentable (UnTrans d) => Trans d => d -> Indent -> d -> d
458 default fill :: Indentable (UnTrans d) => Trans d => Width -> d -> d
459 default fillOrBreak :: Indentable (UnTrans d) => Trans d => Width -> d -> d
460
461 align = noTrans1 align
462 setIndent p i = noTrans . setIndent (unTrans p) i . unTrans
463 incrIndent p i = noTrans . incrIndent (unTrans p) i . unTrans
464 fill = noTrans1 . fill
465 fillOrBreak = noTrans1 . fillOrBreak
466
467 class Listable d where
468 ul :: Traversable f => f d -> d
469 ol :: Traversable f => f d -> d
470 default ul ::
471 Listable (UnTrans d) => Trans d =>
472 Traversable f => f d -> d
473 default ol ::
474 Listable (UnTrans d) => Trans d =>
475 Traversable f => f d -> d
476 ul ds = noTrans $ ul $ unTrans <$> ds
477 ol ds = noTrans $ ol $ unTrans <$> ds
478
479 -- * Class 'Wrappable'
480 class Wrappable d where
481 setWidth :: Maybe Width -> d -> d
482 -- getWidth :: (Maybe Width -> d) -> d
483 breakpoint :: d
484 breakspace :: d
485 breakalt :: d -> d -> d
486 endline :: d
487 default breakpoint :: Wrappable (UnTrans d) => Trans d => d
488 default breakspace :: Wrappable (UnTrans d) => Trans d => d
489 default breakalt :: Wrappable (UnTrans d) => Trans d => d -> d -> d
490 default endline :: Wrappable (UnTrans d) => Trans d => d
491 breakpoint = noTrans breakpoint
492 breakspace = noTrans breakspace
493 breakalt = noTrans2 breakalt
494 endline = noTrans endline
495
496 -- * Class 'Justifiable'
497 class Justifiable d where
498 justify :: d -> d
499
500 -- * Class 'Trans'
501 class Trans repr where
502 -- | Return the underlying @repr@ of the transformer.
503 type UnTrans repr :: Type
504
505 -- | Lift a repr to the transformer's.
506 noTrans :: UnTrans repr -> repr
507 -- | Unlift a repr from the transformer's.
508 unTrans :: repr -> UnTrans repr
509
510 -- | Identity transformation for a unary symantic method.
511 noTrans1 :: (UnTrans repr -> UnTrans repr) -> (repr -> repr)
512 noTrans1 f = noTrans . f . unTrans
513
514 -- | Identity transformation for a binary symantic method.
515 noTrans2
516 :: (UnTrans repr -> UnTrans repr -> UnTrans repr)
517 -> (repr -> repr -> repr)
518 noTrans2 f a b = noTrans (f (unTrans a) (unTrans b))
519
520 -- | Identity transformation for a ternary symantic method.
521 noTrans3
522 :: (UnTrans repr -> UnTrans repr -> UnTrans repr -> UnTrans repr)
523 -> (repr -> repr -> repr -> repr)
524 noTrans3 f a b c = noTrans (f (unTrans a) (unTrans b) (unTrans c))