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