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