]> Git — Sourcephile - haskell/symantic-plaintext.git/blob - src/Symantic/Document/Plain.hs
iface: rename `Symantic.Document.{Lang => Class}`
[haskell/symantic-plaintext.git] / src / Symantic / Document / Plain.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE NoMonomorphismRestriction #-}
3 {-# LANGUAGE UndecidableInstances #-}
4 module Symantic.Document.Plain where
5
6 import Control.Monad (Monad(..))
7 import Data.Bool
8 import Data.Char (Char)
9 import Data.Eq (Eq(..))
10 import Data.Function (($), (.), id)
11 import Data.Functor ((<$>))
12 import Data.Maybe (Maybe(..))
13 import Data.Monoid (Monoid(..))
14 import Data.Ord (Ord(..), Ordering(..))
15 import Data.Semigroup (Semigroup(..))
16 import Data.String (String, IsString(..))
17 import Data.Text (Text)
18 import Data.Tuple (snd)
19 import GHC.Natural (minusNatural,minusNaturalMaybe,quotRemNatural)
20 import Numeric.Natural (Natural)
21 import Prelude (fromIntegral, Num(..), pred)
22 import System.Console.ANSI hiding (SGR)
23 import Text.Show (Show(..), showString, showParen)
24 import qualified Data.Foldable as Fold
25 import qualified Data.List as List
26 import qualified Data.Text.Lazy as TL
27
28 import Symantic.Document.Class
29
30 -- * Type 'Plain'
31 -- | Church encoded for performance concerns.
32 -- Kind like 'ParsecT' in @megaparsec@ but a little bit different
33 -- due to the use of 'PlainFit' for implementing 'breakingSpace' correctly
34 -- when in the left hand side of ('<>').
35 -- Prepending is done using continuation, like in a difference list.
36 newtype Plain d = Plain
37 { unPlain ::
38 {-curr-}PlainInh d ->
39 {-curr-}PlainState d ->
40 {-ok-}( ({-prepend-}(d->d), {-new-}PlainState d) -> PlainFit d) ->
41 PlainFit d
42 -- NOTE: equivalent to:
43 -- ReaderT PlainInh (StateT (PlainState d) (Cont (PlainFit d))) (d->d)
44 }
45 instance (Show d, Spaceable d) => Show (Plain d) where
46 show = show . runPlain
47
48 runPlain :: Spaceable d => Plain d -> d
49 runPlain x =
50 unPlain x
51 defPlainInh
52 defPlainState
53 {-k-}(\(px,_sx) fits _overflow ->
54 -- NOTE: if px fits, then appending mempty fits
55 fits (px mempty) )
56 {-fits-}id
57 {-overflow-}id
58
59 -- ** Type 'PlainState'
60 data PlainState d = PlainState
61 { plainState_buffer :: ![PlainChunk d]
62 , plainState_bufferStart :: !Column
63 -- ^ The 'Column' from which the 'plainState_buffer'
64 -- must be written.
65 , plainState_bufferWidth :: !Width
66 -- ^ The 'Width' of the 'plainState_buffer' so far.
67 , plainState_breakIndent :: !Indent
68 -- ^ The amount of 'Indent' added by 'breakspace'
69 -- that can be reached by breaking the 'space'
70 -- into a 'newlineJustifyingPlain'.
71 } deriving (Show)
72
73 defPlainState :: PlainState d
74 defPlainState = PlainState
75 { plainState_buffer = mempty
76 , plainState_bufferStart = 0
77 , plainState_bufferWidth = 0
78 , plainState_breakIndent = 0
79 }
80
81 -- ** Type 'PlainInh'
82 data PlainInh d = PlainInh
83 { plainInh_width :: !(Maybe Column)
84 , plainInh_justify :: !Bool
85 , plainInh_indent :: !Indent
86 , plainInh_indenting :: !(Plain d)
87 , plainInh_sgr :: ![SGR]
88 }
89
90 defPlainInh :: Spaceable d => PlainInh d
91 defPlainInh = PlainInh
92 { plainInh_width = Nothing
93 , plainInh_justify = False
94 , plainInh_indent = 0
95 , plainInh_indenting = mempty
96 , plainInh_sgr = []
97 }
98
99 -- ** Type 'PlainFit'
100 -- | Double continuation to qualify the returned document
101 -- as fitting or overflowing the given 'plainInh_width'.
102 -- It's like @('Bool',d)@ in a normal style
103 -- (a non continuation-passing-style).
104 type PlainFit d = {-fits-}(d -> d) ->
105 {-overflow-}(d -> d) ->
106 d
107
108 -- ** Type 'PlainChunk'
109 data PlainChunk d
110 = PlainChunk_Ignored !d
111 -- ^ Ignored by the justification but kept in place.
112 -- Used for instance to put ANSI sequences.
113 | PlainChunk_Word !(Word d)
114 | PlainChunk_Spaces !Width
115 -- ^ 'spaces' preserved to be interleaved
116 -- correctly with 'PlainChunk_Ignored'.
117 instance Show d => Show (PlainChunk d) where
118 showsPrec p x =
119 showParen (p>10) $
120 case x of
121 PlainChunk_Ignored d ->
122 showString "Z " .
123 showsPrec 11 d
124 PlainChunk_Word (Word d) ->
125 showString "W " .
126 showsPrec 11 d
127 PlainChunk_Spaces s ->
128 showString "S " .
129 showsPrec 11 s
130 instance Lengthable d => Lengthable (PlainChunk d) where
131 width = \case
132 PlainChunk_Ignored{} -> 0
133 PlainChunk_Word d -> width d
134 PlainChunk_Spaces s -> s
135 nullWidth = \case
136 PlainChunk_Ignored{} -> True
137 PlainChunk_Word d -> nullWidth d
138 PlainChunk_Spaces s -> s == 0
139 instance From [SGR] d => From [SGR] (PlainChunk d) where
140 from sgr = PlainChunk_Ignored (from sgr)
141
142 runPlainChunk :: Spaceable d => PlainChunk d -> d
143 runPlainChunk = \case
144 PlainChunk_Ignored d -> d
145 PlainChunk_Word (Word d) -> d
146 PlainChunk_Spaces s -> spaces s
147
148 instance Semigroup d => Semigroup (Plain d) where
149 Plain x <> Plain y = Plain $ \inh st k ->
150 x inh st $ \(px,sx) ->
151 y inh sx $ \(py,sy) ->
152 k (px.py,sy)
153 instance Monoid d => Monoid (Plain d) where
154 mempty = Plain $ \_inh st k -> k (id,st)
155 mappend = (<>)
156 instance Spaceable d => Spaceable (Plain d) where
157 -- | The default 'newline' does not justify 'plainState_buffer',
158 -- for that use 'newlineJustifyingPlain'.
159 newline = Plain $ \inh st ->
160 unPlain
161 ( newlinePlain
162 <> indentPlain
163 <> propagatePlain (plainState_breakIndent st)
164 <> flushlinePlain
165 ) inh st
166 where
167 indentPlain = Plain $ \inh ->
168 unPlain
169 (plainInh_indenting inh)
170 inh{plainInh_justify=False}
171 newlinePlain = Plain $ \inh st k ->
172 k (\next ->
173 (if plainInh_justify inh
174 then joinLinePlainChunk $ List.reverse $ plainState_buffer st
175 else mempty
176 )<>newline<>next
177 , st
178 { plainState_bufferStart = 0
179 , plainState_bufferWidth = 0
180 , plainState_buffer = mempty
181 })
182 propagatePlain breakIndent = Plain $ \inh st1 k fits overflow ->
183 k (id,st1)
184 fits
185 {-overflow-}(
186 -- NOTE: the text after this newline overflows,
187 -- so propagate the overflow before this 'newline',
188 -- if and only if there is a 'breakspace' before this 'newline'
189 -- whose replacement by a 'newline' indents to a lower indent
190 -- than this 'newline''s indent.
191 -- Otherwise there is no point in propagating the overflow.
192 if breakIndent < plainInh_indent inh
193 then overflow
194 else fits
195 )
196 space = spaces 1
197 spaces n = Plain $ \inh st@PlainState{..} k fits overflow ->
198 let newWidth = plainState_bufferStart + plainState_bufferWidth + n in
199 if plainInh_justify inh
200 then
201 let newState = st
202 { plainState_buffer =
203 case plainState_buffer of
204 PlainChunk_Spaces s:buf -> PlainChunk_Spaces (s+n):buf
205 buf -> PlainChunk_Spaces n:buf
206 , plainState_bufferWidth = plainState_bufferWidth + n
207 } in
208 case plainInh_width inh of
209 Just maxWidth | maxWidth < newWidth ->
210 overflow $ k (id{-(d<>)-}, newState) fits overflow
211 _ -> k (id{-(d<>)-}, newState) fits overflow
212 else
213 let newState = st
214 { plainState_bufferWidth = plainState_bufferWidth + n
215 } in
216 case plainInh_width inh of
217 Just maxWidth | maxWidth < newWidth ->
218 overflow $ k ((spaces n <>), newState) fits fits
219 _ -> k ((spaces n <>), newState) fits overflow
220 instance (From (Word s) d, Semigroup d, Lengthable s) =>
221 From (Word s) (Plain d) where
222 from s = Plain $ \inh st@PlainState{..} k fits overflow ->
223 let wordWidth = width s in
224 if wordWidth <= 0
225 then k (id,st) fits overflow
226 else
227 let newBufferWidth = plainState_bufferWidth + wordWidth in
228 let newWidth = plainState_bufferStart + newBufferWidth in
229 if plainInh_justify inh
230 then
231 let newState = st
232 { plainState_buffer =
233 PlainChunk_Word (Word (from s)) :
234 plainState_buffer
235 , plainState_bufferWidth = newBufferWidth
236 } in
237 case plainInh_width inh of
238 Just maxWidth | maxWidth < newWidth ->
239 overflow $ k (id, newState) fits overflow
240 _ -> k (id, newState) fits overflow
241 else
242 let newState = st
243 { plainState_bufferWidth = newBufferWidth
244 } in
245 case plainInh_width inh of
246 Just maxWidth | maxWidth < newWidth ->
247 overflow $ k ((from s <>), newState) fits fits
248 _ -> k ((from s <>), newState) fits overflow
249 instance (From (Word s) d, Lengthable s, Spaceable d, Splitable s) =>
250 From (Line s) (Plain d) where
251 from =
252 mconcat .
253 List.intersperse breakspace .
254 (from <$>) .
255 words .
256 unLine
257 instance Spaceable d => Indentable (Plain d) where
258 align p = (flushlinePlain <>) $ Plain $ \inh st ->
259 let col = plainState_bufferStart st + plainState_bufferWidth st in
260 unPlain p inh
261 { plainInh_indent = col
262 , plainInh_indenting =
263 if plainInh_indent inh <= col
264 then
265 plainInh_indenting inh <>
266 spaces (col`minusNatural`plainInh_indent inh)
267 else spaces col
268 } st
269 setIndent d i p = Plain $ \inh ->
270 unPlain p inh
271 { plainInh_indent = i
272 , plainInh_indenting = d
273 }
274 incrIndent d i p = Plain $ \inh ->
275 unPlain p inh
276 { plainInh_indent = plainInh_indent inh + i
277 , plainInh_indenting = plainInh_indenting inh <> d
278 }
279
280 fill m p = Plain $ \inh0 st0 ->
281 let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
282 let p1 = Plain $ \inh1 st1 ->
283 let col = plainState_bufferStart st1 + plainState_bufferWidth st1 in
284 unPlain
285 (if col <= maxCol
286 then spaces (maxCol`minusNatural`col)
287 else mempty)
288 inh1 st1
289 in
290 unPlain (p <> p1) inh0 st0
291 fillOrBreak m p = Plain $ \inh0 st0 ->
292 let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
293 let p1 = Plain $ \inh1 st1 ->
294 let col = plainState_bufferStart st1 + plainState_bufferWidth st1 in
295 unPlain
296 (case col`compare`maxCol of
297 LT -> spaces (maxCol`minusNatural`col)
298 EQ -> mempty
299 GT -> incrIndent (spaces m) m newline
300 ) inh1 st1
301 in
302 unPlain (p <> p1) inh0 st0
303 instance (Spaceable d, From (Word Char) d, From (Word String) d) => Listable (Plain d) where
304 ul ds =
305 catV $
306 (<$> ds) $ \d ->
307 from (Word '-')<>space<>flushlinePlain<>align d{-<>flushlinePlain-}
308 ol ds =
309 catV $ snd $
310 Fold.foldr
311 (\d (i, acc) ->
312 (pred i, (from i<>from (Word '.')<>space<>flushlinePlain<>align d{-<>flushlinePlain-}) : acc)
313 ) (Fold.length ds, []) ds
314 instance Spaceable d => Justifiable (Plain d) where
315 justify p = (\x -> flushlinePlain <> x <> flushlinePlain) $ Plain $ \inh ->
316 unPlain p inh{plainInh_justify=True}
317
318 -- | Commit 'plainState_buffer' upto there, so that it won't be justified.
319 flushlinePlain :: Spaceable d => Plain d
320 flushlinePlain = Plain $ \_inh st k ->
321 k( (joinLinePlainChunk (collapsePlainChunkSpaces <$> List.reverse (plainState_buffer st)) <>)
322 , st
323 { plainState_bufferStart = plainState_bufferStart st + plainState_bufferWidth st
324 , plainState_bufferWidth = 0
325 , plainState_buffer = mempty
326 }
327 )
328
329 collapsePlainChunkSpaces :: PlainChunk d -> PlainChunk d
330 collapsePlainChunkSpaces = \case
331 PlainChunk_Spaces s -> PlainChunk_Spaces (if s > 0 then 1 else 0)
332 x -> x
333
334 instance Spaceable d => Wrappable (Plain d) where
335 setWidth w p = Plain $ \inh ->
336 unPlain p inh{plainInh_width=w}
337 breakpoint = Plain $ \inh st k fits overflow ->
338 k(id, st {plainState_breakIndent = plainInh_indent inh})
339 fits
340 {-overflow-}(\_r -> unPlain newlineJustifyingPlain inh st k fits overflow)
341 breakspace = Plain $ \inh st k fits overflow ->
342 k( if plainInh_justify inh then id else (space <>)
343 , st
344 { plainState_buffer =
345 if plainInh_justify inh
346 then case plainState_buffer st of
347 PlainChunk_Spaces s:bs -> PlainChunk_Spaces (s+1):bs
348 bs -> PlainChunk_Spaces 1:bs
349 else plainState_buffer st
350 , plainState_bufferWidth = plainState_bufferWidth st + 1
351 , plainState_breakIndent = plainInh_indent inh
352 }
353 )
354 fits
355 {-overflow-}(\_r -> unPlain newlineJustifyingPlain inh st k fits overflow)
356 breakalt x y = Plain $ \inh st k fits overflow ->
357 -- NOTE: breakalt must be y if and only if x does not fit,
358 -- hence the use of dummyK to limit the test
359 -- to overflows raised within x, and drop those raised after x.
360 unPlain x inh st dummyK
361 {-fits-} (\_r -> unPlain x inh st k fits overflow)
362 {-overflow-}(\_r -> unPlain y inh st k fits overflow)
363 where
364 dummyK (px,_sx) fits _overflow =
365 -- NOTE: if px fits, then appending mempty fits
366 fits (px mempty)
367 endline = Plain $ \inh st k fits _overflow ->
368 let col = plainState_bufferStart st + plainState_bufferWidth st in
369 case plainInh_width inh >>= (`minusNaturalMaybe` col) of
370 Nothing -> k (id, st) fits fits
371 Just w ->
372 let newState = st
373 { plainState_bufferWidth = plainState_bufferWidth st + w
374 } in
375 k (id,newState) fits fits
376
377 -- | Like 'newline', but justify 'plainState_buffer' before.
378 newlineJustifyingPlain :: Spaceable d => Plain d
379 newlineJustifyingPlain = Plain $ \inh st ->
380 unPlain
381 ( newlinePlain
382 <> indentPlain
383 <> propagatePlain (plainState_breakIndent st)
384 <> flushlinePlain
385 ) inh st
386 where
387 indentPlain = Plain $ \inh ->
388 unPlain
389 (plainInh_indenting inh)
390 inh{plainInh_justify=False}
391 newlinePlain = Plain $ \inh st k ->
392 k (\next ->
393 (if plainInh_justify inh
394 then justifyLinePlain inh st
395 else mempty
396 )<>newline<>next
397 , st
398 { plainState_bufferStart = 0
399 , plainState_bufferWidth = 0
400 , plainState_buffer = mempty
401 })
402 propagatePlain breakIndent = Plain $ \inh st1 k fits overflow ->
403 k (id,st1)
404 fits
405 {-overflow-}(
406 -- NOTE: the text after this newline overflows,
407 -- so propagate the overflow before this 'newline',
408 -- if and only if there is a 'breakspace' before this 'newline'
409 -- whose replacement by a 'newline' indents to a lower indent
410 -- than this 'newline''s indent.
411 -- Otherwise there is no point in propagating the overflow.
412 if breakIndent < plainInh_indent inh
413 then overflow
414 else fits
415 )
416
417 -- String
418 instance (From (Word String) d, Spaceable d) =>
419 From String (Plain d) where
420 from =
421 mconcat .
422 List.intersperse newline .
423 (from <$>) .
424 lines
425 instance (From (Word String) d, Spaceable d) =>
426 IsString (Plain d) where
427 fromString = from
428 -- Text
429 instance (From (Word Text) d, Spaceable d) =>
430 From Text (Plain d) where
431 from =
432 mconcat .
433 List.intersperse newline .
434 (from <$>) .
435 lines
436 instance (From (Word TL.Text) d, Spaceable d) =>
437 From TL.Text (Plain d) where
438 from =
439 mconcat .
440 List.intersperse newline .
441 (from <$>) .
442 lines
443 -- Char
444 instance (From (Word Char) d, Spaceable d) =>
445 From Char (Plain d) where
446 from ' ' = breakspace
447 from '\n' = newline
448 from c = from (Word c)
449
450 instance (From [SGR] d, Semigroup d) => From [SGR] (Plain d) where
451 from sgr = Plain $ \inh st k ->
452 if plainInh_justify inh
453 then k (id, st {plainState_buffer = PlainChunk_Ignored (from sgr) : plainState_buffer st})
454 else k ((from sgr <>), st)
455
456 -- * Justifying
457 justifyLinePlain ::
458 Spaceable d =>
459 PlainInh d -> PlainState d -> d
460 justifyLinePlain inh PlainState{..} =
461 case plainInh_width inh of
462 Nothing -> joinLinePlainChunk $ List.reverse plainState_buffer
463 Just maxWidth ->
464 if maxWidth < plainState_bufferStart
465 || maxWidth < plainInh_indent inh
466 then joinLinePlainChunk $ List.reverse plainState_buffer
467 else
468 let superfluousSpaces = Fold.foldr
469 (\c acc ->
470 acc + case c of
471 PlainChunk_Ignored{} -> 0
472 PlainChunk_Word{} -> 0
473 PlainChunk_Spaces s -> s`minusNatural`(min 1 s))
474 0 plainState_buffer in
475 let minBufferWidth =
476 -- NOTE: cap the spaces at 1,
477 -- to let justifyWidth decide where to add spaces.
478 plainState_bufferWidth`minusNatural`superfluousSpaces in
479 let justifyWidth =
480 -- NOTE: when minBufferWidth is not breakable,
481 -- the width of justification can be wider than
482 -- what remains to reach maxWidth.
483 max minBufferWidth $
484 maxWidth`minusNatural`plainState_bufferStart
485 in
486 let wordCount = countWordsPlain plainState_buffer in
487 unLine $ padLinePlainChunkInits justifyWidth $
488 (minBufferWidth,wordCount,List.reverse plainState_buffer)
489
490 -- | @('countWordsPlain' ps)@ returns the number of words in @(ps)@
491 -- clearly separated by spaces.
492 countWordsPlain :: [PlainChunk d] -> Natural
493 countWordsPlain = go False 0
494 where
495 go inWord acc = \case
496 [] -> acc
497 PlainChunk_Word{}:xs ->
498 if inWord
499 then go inWord acc xs
500 else go True (acc+1) xs
501 PlainChunk_Spaces s:xs
502 | s == 0 -> go inWord acc xs
503 | otherwise -> go False acc xs
504 PlainChunk_Ignored{}:xs -> go inWord acc xs
505
506 -- | @('justifyPadding' a b)@ returns the padding lengths
507 -- to reach @(a)@ in @(b)@ pads,
508 -- using the formula: @(a '==' m'*'(q '+' q'+'1) '+' ('r'-'m)'*'(q'+'1) '+' (b'-'r'-'m)'*'q)@
509 -- where @(q+1)@ and @(q)@ are the two padding lengths used and @(m = min (b-r) r)@.
510 --
511 -- A simple implementation of 'justifyPadding' could be:
512 -- @
513 -- 'justifyPadding' a b =
514 -- 'join' ('List.replicate' m [q,q'+'1])
515 -- <> ('List.replicate' (r'-'m) (q'+'1)
516 -- <> ('List.replicate' ((b'-'r)'-'m) q
517 -- where
518 -- (q,r) = a`divMod`b
519 -- m = 'min' (b-r) r
520 -- @
521 justifyPadding :: Natural -> Natural -> [Natural]
522 justifyPadding a b = go r (b-r) -- NOTE: r >= 0 && b-r >= 0 due to 'divMod'
523 where
524 (q,r) = a`quotRemNatural`b
525
526 go 0 bmr = List.replicate (fromIntegral bmr) q -- when min (b-r) r == b-r
527 go rr 0 = List.replicate (fromIntegral rr) (q+1) -- when min (b-r) r == r
528 go rr bmr = q:(q+1) : go (rr`minusNatural`1) (bmr`minusNatural`1)
529
530 padLinePlainChunkInits ::
531 Spaceable d =>
532 Width -> (Natural, Natural, [PlainChunk d]) -> Line d
533 padLinePlainChunkInits maxWidth (lineWidth,wordCount,line) = Line $
534 if maxWidth <= lineWidth
535 -- The gathered line reached or overreached the maxWidth,
536 -- hence no padding id needed.
537 || wordCount <= 1
538 -- The case maxWidth <= lineWidth && wordCount == 1
539 -- can happen if first word's length is < maxWidth
540 -- but second word's len is >= maxWidth.
541 then joinLinePlainChunk line
542 else
543 -- Share the missing spaces as evenly as possible
544 -- between the words of the line.
545 padLinePlainChunk line $ justifyPadding (maxWidth-lineWidth) (wordCount-1)
546
547 -- | Just concat 'PlainChunk's with no justification.
548 joinLinePlainChunk :: Monoid d => Spaceable d => [PlainChunk d] -> d
549 joinLinePlainChunk = mconcat . (runPlainChunk <$>)
550
551 -- | Interleave 'PlainChunk's with 'Width's from 'justifyPadding'.
552 padLinePlainChunk :: Spaceable d => [PlainChunk d] -> [Width] -> d
553 padLinePlainChunk = go
554 where
555 go (w:ws) lls@(l:ls) =
556 case w of
557 PlainChunk_Spaces _s -> spaces (fromIntegral (l+1)) <> go ws ls
558 _ -> runPlainChunk w <> go ws lls
559 go (w:ws) [] = runPlainChunk w <> go ws []
560 go [] _ls = mempty
561
562 -- * Escaping
563 instance (Semigroup d, From [SGR] d) => Colorable16 (Plain d) where
564 reverse = plainSGR $ SetSwapForegroundBackground True
565 black = plainSGR $ SetColor Foreground Dull Black
566 red = plainSGR $ SetColor Foreground Dull Red
567 green = plainSGR $ SetColor Foreground Dull Green
568 yellow = plainSGR $ SetColor Foreground Dull Yellow
569 blue = plainSGR $ SetColor Foreground Dull Blue
570 magenta = plainSGR $ SetColor Foreground Dull Magenta
571 cyan = plainSGR $ SetColor Foreground Dull Cyan
572 white = plainSGR $ SetColor Foreground Dull White
573 blacker = plainSGR $ SetColor Foreground Vivid Black
574 redder = plainSGR $ SetColor Foreground Vivid Red
575 greener = plainSGR $ SetColor Foreground Vivid Green
576 yellower = plainSGR $ SetColor Foreground Vivid Yellow
577 bluer = plainSGR $ SetColor Foreground Vivid Blue
578 magentaer = plainSGR $ SetColor Foreground Vivid Magenta
579 cyaner = plainSGR $ SetColor Foreground Vivid Cyan
580 whiter = plainSGR $ SetColor Foreground Vivid White
581 onBlack = plainSGR $ SetColor Background Dull Black
582 onRed = plainSGR $ SetColor Background Dull Red
583 onGreen = plainSGR $ SetColor Background Dull Green
584 onYellow = plainSGR $ SetColor Background Dull Yellow
585 onBlue = plainSGR $ SetColor Background Dull Blue
586 onMagenta = plainSGR $ SetColor Background Dull Magenta
587 onCyan = plainSGR $ SetColor Background Dull Cyan
588 onWhite = plainSGR $ SetColor Background Dull White
589 onBlacker = plainSGR $ SetColor Background Vivid Black
590 onRedder = plainSGR $ SetColor Background Vivid Red
591 onGreener = plainSGR $ SetColor Background Vivid Green
592 onYellower = plainSGR $ SetColor Background Vivid Yellow
593 onBluer = plainSGR $ SetColor Background Vivid Blue
594 onMagentaer = plainSGR $ SetColor Background Vivid Magenta
595 onCyaner = plainSGR $ SetColor Background Vivid Cyan
596 onWhiter = plainSGR $ SetColor Background Vivid White
597 instance (Semigroup d, From [SGR] d) => Decorable (Plain d) where
598 bold = plainSGR $ SetConsoleIntensity BoldIntensity
599 underline = plainSGR $ SetUnderlining SingleUnderline
600 italic = plainSGR $ SetItalicized True
601
602 plainSGR ::
603 Semigroup d =>
604 From [SGR] d =>
605 SGR -> Plain d -> Plain d
606 plainSGR newSGR p = before <> middle <> after
607 where
608 before = Plain $ \inh st k ->
609 let d = from [newSGR] in
610 if plainInh_justify inh
611 then k (id, st
612 { plainState_buffer =
613 PlainChunk_Ignored d :
614 plainState_buffer st
615 })
616 else k ((d <>), st)
617 middle = Plain $ \inh ->
618 unPlain p inh{plainInh_sgr=newSGR:plainInh_sgr inh}
619 after = Plain $ \inh st k ->
620 let d = from $ Reset : List.reverse (plainInh_sgr inh) in
621 if plainInh_justify inh
622 then k (id, st
623 { plainState_buffer =
624 PlainChunk_Ignored d :
625 plainState_buffer st
626 })
627 else k ((d <>), st)