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