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