1 {-# LANGUAGE NoMonomorphismRestriction #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE UndecidableInstances #-}
4 module Symantic.Formatter.Plain where
6 import Control.Monad (Monad(..))
8 import Data.Char (Char)
9 import Data.Eq (Eq(..))
10 import Data.Function (($), (.), id)
11 import Data.Functor ((<$>))
13 import Data.Kind (Type)
14 import Data.Maybe (Maybe(..))
15 import Data.Monoid (Monoid(..))
16 import Data.Ord (Ord(..), Ordering(..))
17 import Data.Semigroup (Semigroup(..))
18 import Data.String (IsString(..), String)
19 import GHC.Natural (minusNatural,minusNaturalMaybe,quotRemNatural)
20 import Numeric.Natural (Natural)
21 import Prelude (fromIntegral, Num(..), pred, error)
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.Tuple as Tuple
27 import qualified Data.Text as T
28 import qualified Data.Text.Lazy as TL
29 --import qualified Data.Text.Lazy.Builder as TLB
34 import Symantic.Formatter.Class
35 import Symantic.Formatter.Output
38 -- | Church encoded for performance concerns.
39 -- Kind like 'ParsecT' in @megaparsec@ but a little bit different
40 -- due to the use of 'PlainFit' for implementing 'breakingSpace' correctly
41 -- when in the left hand side of ('<.>').
42 -- Prepending is done using continuation, like in a difference list.
43 newtype Plain (o::Type) a = Plain
46 {-curr-}PlainState o ->
47 {-ok-}( ({-prepend-}(o->o), {-new-}PlainState o) -> PlainFit o) ->
49 -- NOTE: equivalent to:
50 -- ReaderT PlainInh (StateT (PlainState o) (Cont (PlainFit o))) (o->o)
53 instance Semigroup o => ProductFunctor (Plain o) where
54 x <.> y = Plain $ \(a,b) inh st k ->
55 unPlain x a inh st $ \(px,sx) ->
56 unPlain y b inh sx $ \(py,sy) ->
58 x .> y = Plain $ \b inh st k ->
59 unPlain x () inh st $ \(px,sx) ->
60 unPlain y b inh sx $ \(py,sy) ->
62 x <. y = Plain $ \a inh st k ->
63 unPlain x a inh st $ \(px,sx) ->
64 unPlain y () inh sx $ \(py,sy) ->
66 instance Emptyable (Plain o) where
67 empty = Plain $ \_a _inh st k -> k (id,st)
68 instance Outputable o => Repeatable (Plain o) where
69 many0 item = Plain $ \as ->
70 unPlain (concat ((`void` item) <$> as)) ()
71 many1 item = Plain $ \case
73 as -> unPlain (concat ((`void` item) <$> as)) ()
76 instance (Convertible String o, Outputable o) => IsString (Plain o ()) where
78 instance (Convertible String o, Outputable o) => Convertible String (Plain o ()) where
81 List.intersperse newline .
84 List.intersperse breakspace .
88 instance (Convertible T.Text o, Convertible Char o, Outputable o) => Convertible T.Text (Plain o ()) where
91 List.intersperse newline .
94 List.intersperse breakspace .
98 instance (Convertible TL.Text o, Convertible Char o, Outputable o) => Convertible TL.Text (Plain o ()) where
101 List.intersperse newline .
104 List.intersperse breakspace .
108 --intersperse sep = concat . List.intersperse sep
109 instance (Convertible String o, Outputable o) => Inferable Int (Plain o) where
110 infer = showWordPlain
111 instance (Convertible String o, Outputable o) => Inferable Natural (Plain o) where
112 infer = showWordPlain
113 instance (Convertible String o, Outputable o) => Inferable (Word String) (Plain o) where
114 infer = Plain $ ($ ()) . unPlain . wordPlain
115 instance (Convertible String o, Outputable o) => Inferable String (Plain o) where
116 infer = Plain $ ($ ()) . unPlain . fromString
117 instance (Convertible T.Text o, Convertible Char o, Outputable o) => Inferable T.Text (Plain o) where
118 infer = Plain $ ($ ()) . unPlain . convert
119 instance (Convertible TL.Text o, Convertible Char o, Outputable o) => Inferable TL.Text (Plain o) where
120 infer = Plain $ ($ ()) . unPlain . convert
121 instance Outputable o => Inferable Char (Plain o) where
122 infer = Plain $ \case
123 '\n' -> unPlain newline ()
124 ' ' -> unPlain breakspace ()
125 c -> unPlain (wordPlain (Word c)) ()
126 instance Outputable o => Inferable (Word Char) (Plain o) where
127 infer = Plain $ \c -> unPlain (wordPlain c) ()
130 Convertible String o =>
132 Inferable a (Plain o) => Plain o a
133 showWordPlain = Plain $
134 ($ ()) . unPlain . wordPlain .
137 runPlain :: Monoid o => Plain o a -> a -> o
142 {-k-}(\(px,_sx) fits _overflow ->
143 -- NOTE: if px fits, then appending mempty fits
148 -- ** Type 'PlainState'
149 data PlainState o = PlainState
150 { plainState_buffer :: ![PlainChunk o]
151 , plainState_bufferStart :: !Column
152 -- ^ The 'Column' from which the 'plainState_buffer'
154 , plainState_bufferWidth :: !Width
155 -- ^ The 'Width' of the 'plainState_buffer' so far.
156 , plainState_breakIndent :: !Indent
157 -- ^ The amount of 'Indent' added by 'breakspace'
158 -- that can be reached by breaking the 'space'
159 -- into a 'newlineJustifyingPlain'.
162 defPlainState :: PlainState o
163 defPlainState = PlainState
164 { plainState_buffer = mempty
165 , plainState_bufferStart = 0
166 , plainState_bufferWidth = 0
167 , plainState_breakIndent = 0
170 -- ** Type 'PlainInh'
171 data PlainInh o = PlainInh
172 { plainInh_width :: !(Maybe Column)
173 , plainInh_justify :: !Bool
174 , plainInh_indent :: !Indent
175 , plainInh_indenting :: !(Plain o ())
176 , plainInh_sgr :: ![SGR]
179 defPlainInh :: Monoid o => PlainInh o
180 defPlainInh = PlainInh
181 { plainInh_width = Nothing
182 , plainInh_justify = False
183 , plainInh_indent = 0
184 , plainInh_indenting = empty
188 -- ** Type 'PlainFit'
189 -- | Double continuation to qualify the returned document
190 -- as fitting or overflowing the given 'plainInh_width'.
191 -- It's like @('Bool',o)@ in a normal style
192 -- (a non continuation-passing-style).
195 {-overflow-}(o -> o) ->
198 -- ** Type 'PlainChunk'
200 = PlainChunk_Ignored !o
201 -- ^ Ignored by the justification but kept in place.
202 -- Used for instance to put ANSI sequences.
203 | PlainChunk_Word !(Word o)
204 | PlainChunk_Spaces !Width
205 -- ^ 'spaces' preserved to be interleaved
206 -- correctly with 'PlainChunk_Ignored'.
207 instance Show o => Show (PlainChunk o) where
211 PlainChunk_Ignored o ->
214 PlainChunk_Word (Word o) ->
217 PlainChunk_Spaces s ->
220 instance Lengthable o => Lengthable (PlainChunk o) where
222 PlainChunk_Ignored{} -> 0
223 PlainChunk_Word o -> length o
224 PlainChunk_Spaces s -> s
226 PlainChunk_Ignored{} -> True
227 PlainChunk_Word o -> isEmpty o
228 PlainChunk_Spaces s -> s == 0
229 --instance From [SGR] o => From [SGR] (PlainChunk o) where
230 -- from sgr = PlainChunk_Ignored (from sgr)
232 runPlainChunk :: Outputable o => PlainChunk o -> o
233 runPlainChunk = \case
234 PlainChunk_Ignored o -> o
235 PlainChunk_Word (Word o) -> o
236 PlainChunk_Spaces s -> repeatedChar s ' '
238 instance Voidable (Plain o) where
239 void a p = Plain $ \() -> unPlain p a
240 instance (Convertible Char o, Outputable o) => Spaceable (Plain o) where
242 spaces n = Plain $ \() inh st@PlainState{..} k fits overflow ->
243 let newWidth = plainState_bufferStart + plainState_bufferWidth + n in
244 if plainInh_justify inh
247 { plainState_buffer =
248 case plainState_buffer of
249 PlainChunk_Spaces s:buf -> PlainChunk_Spaces (s+n):buf
250 buf -> PlainChunk_Spaces n:buf
251 , plainState_bufferWidth = plainState_bufferWidth + n
253 case plainInh_width inh of
254 Just maxWidth | maxWidth < newWidth ->
255 overflow $ k (id{-(o<>)-}, newState) fits overflow
256 _ -> k (id{-(o<>)-}, newState) fits overflow
259 { plainState_bufferWidth = plainState_bufferWidth + n
261 case plainInh_width inh of
262 Just maxWidth | maxWidth < newWidth ->
263 overflow $ k ((repeatedChar n ' ' <>), newState) fits fits
264 _ -> k ((repeatedChar n ' ' <>), newState) fits overflow
265 instance (Outputable o) => Newlineable (Plain o) where
266 -- | The default 'newline' does not justify 'plainState_buffer',
267 -- for that use 'newlineJustifyingPlain'.
268 newline = Plain $ \() inh st ->
272 <. propagatePlain (plainState_breakIndent st)
276 indentPlain = Plain $ \() inh ->
278 (plainInh_indenting inh)
279 () inh{plainInh_justify=False}
280 newlinePlain = Plain $ \() inh st k ->
282 (if plainInh_justify inh
283 then joinLinePlainChunk $ List.reverse $ plainState_buffer st
287 { plainState_bufferStart = 0
288 , plainState_bufferWidth = 0
289 , plainState_buffer = mempty
291 propagatePlain breakIndent = Plain $ \() inh st1 k fits overflow ->
295 -- NOTE: the text after this newline overflows,
296 -- so propagate the overflow before this 'newline',
297 -- if and only if there is a 'breakspace' before this 'newline'
298 -- whose replacement by a 'newline' indents to a lower indent
299 -- than this 'newline''s indent.
300 -- Otherwise there is no point in propagating the overflow.
301 if breakIndent < plainInh_indent inh
306 -- | Commit 'plainState_buffer' upto there, so that it won'o be justified.
307 flushlinePlain :: Outputable o => Plain o ()
308 flushlinePlain = Plain $ \() _inh st k ->
309 k( (joinLinePlainChunk (collapsePlainChunkSpaces <$> List.reverse (plainState_buffer st)) <>)
311 { plainState_bufferStart = plainState_bufferStart st + plainState_bufferWidth st
312 , plainState_bufferWidth = 0
313 , plainState_buffer = mempty
317 -- | Just concat 'PlainChunk's with no justification.
318 joinLinePlainChunk :: Outputable o => [PlainChunk o] -> o
319 joinLinePlainChunk = mconcat . (runPlainChunk <$>)
321 collapsePlainChunkSpaces :: PlainChunk o -> PlainChunk o
322 collapsePlainChunkSpaces = \case
323 PlainChunk_Spaces s -> PlainChunk_Spaces (if s > 0 then 1 else 0)
327 Lengthable i => Convertible i o => Outputable o =>
329 wordPlain inp = Plain $ \() inh st@PlainState{..} k fits overflow ->
330 let wordWidth = length inp in
331 let out = convert inp in
333 then k (id,st) fits overflow
335 let newBufferWidth = plainState_bufferWidth + wordWidth in
336 let newWidth = plainState_bufferStart + newBufferWidth in
337 if plainInh_justify inh
340 { plainState_buffer = PlainChunk_Word out : plainState_buffer
341 , plainState_bufferWidth = newBufferWidth
343 case plainInh_width inh of
344 Just maxWidth | maxWidth < newWidth ->
345 overflow $ k (id, newState) fits overflow
346 _ -> k (id, newState) fits overflow
349 { plainState_bufferWidth = newBufferWidth
351 case plainInh_width inh of
352 Just maxWidth | maxWidth < newWidth ->
353 overflow $ k ((unWord out <>), newState) fits fits
354 _ -> k ((unWord out <>), newState) fits overflow
356 instance (Convertible Char o, Outputable o) => Indentable (Plain o) where
357 align p = (flushlinePlain .>) $ Plain $ \a inh st ->
358 let col = plainState_bufferStart st + plainState_bufferWidth st in
360 { plainInh_indent = col
361 , plainInh_indenting =
362 if plainInh_indent inh <= col
364 plainInh_indenting inh .>
365 spaces (col`minusNatural`plainInh_indent inh)
368 setIndent o i p = Plain $ \a inh ->
370 { plainInh_indent = i
371 , plainInh_indenting = o
373 incrIndent o i p = Plain $ \a inh ->
375 { plainInh_indent = plainInh_indent inh + i
376 , plainInh_indenting = plainInh_indenting inh .> o
378 fill m p = Plain $ \a inh0 st0 ->
379 let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
380 let p1 = Plain $ \() inh1 st1 ->
381 let col = plainState_bufferStart st1 + plainState_bufferWidth st1 in
384 then spaces (maxCol`minusNatural`col)
388 unPlain (p <. p1) a inh0 st0
389 fillOrBreak m p = Plain $ \a inh0 st0 ->
390 let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
391 let p1 = Plain $ \() inh1 st1 ->
392 let col = plainState_bufferStart st1 + plainState_bufferWidth st1 in
394 (case col`compare`maxCol of
395 LT -> spaces (maxCol`minusNatural`col)
397 GT -> incrIndent (spaces m) m newline
400 unPlain (p <. p1) a inh0 st0
401 instance (Convertible Char o, Convertible String o, Outputable o) => Listable (Plain o) where
405 wordPlain (Word '-').>space.>flushlinePlain
413 , ( wordPlain (Word (show n))
414 .> wordPlain (Word '.') .> space
420 ) (Fold.length is, []) is
421 unorderedList li = intercalate_ newline $
422 wordPlain (Word '-') .> space .> flushlinePlain .> align li
423 orderedList li = Plain $ \as ->
424 unPlain (intercalate_ newline item)
427 item = Plain $ \(i::Natural, a) ->
430 .> wordPlain (Word '.') .> space
433 intercalate_ sep li = Plain $ \as ->
434 unPlain (concat (List.intersperse sep ((`void` li) <$> as))) ()
435 list_ opn sep cls li =
437 (opn .> intercalate_ (sep .> space) li <. cls)
438 (align $ opn .> space
439 .> intercalate_ (newline .> sep .> space) li
441 instance Outputable o => Justifiable (Plain o) where
442 justify p = (\x -> flushlinePlain .> x <. flushlinePlain) $ Plain $ \a inh ->
443 unPlain p a inh{plainInh_justify=True}
444 instance Outputable o => Wrappable (Plain o) where
445 setWidth w p = Plain $ \a inh ->
446 unPlain p a inh{plainInh_width=w}
447 breakpoint = Plain $ \() inh st k fits overflow ->
448 k(id, st{plainState_breakIndent = plainInh_indent inh})
450 {-overflow-}(\_r -> unPlain newlineJustifyingPlain () inh st k fits overflow)
451 breakspace = Plain $ \() inh st k fits overflow ->
452 k( if plainInh_justify inh then id else (char ' ' <>)
454 { plainState_buffer =
455 if plainInh_justify inh
456 then case plainState_buffer st of
457 PlainChunk_Spaces s:bs -> PlainChunk_Spaces (s+1):bs
458 bs -> PlainChunk_Spaces 1:bs
459 else plainState_buffer st
460 , plainState_bufferWidth = plainState_bufferWidth st + 1
461 , plainState_breakIndent = plainInh_indent inh
465 {-overflow-}(\_r -> unPlain newlineJustifyingPlain () inh st k fits overflow)
466 breakalt x y = Plain $ \a inh st k fits overflow ->
467 -- NOTE: breakalt must be y if and only if x does not fit,
468 -- hence the use of dummyK to limit the test
469 -- to overflows raised within x, and drop those raised after x.
470 unPlain x a inh st dummyK
471 {-fits-} (\_r -> unPlain x a inh st k fits overflow)
472 {-overflow-}(\_r -> unPlain y a inh st k fits overflow)
474 dummyK (px,_sx) fits _overflow =
475 -- NOTE: if px fits, then appending mempty fits
477 endline = Plain $ \() inh st k fits _overflow ->
478 let col = plainState_bufferStart st + plainState_bufferWidth st in
479 case plainInh_width inh >>= (`minusNaturalMaybe` col) of
480 Nothing -> k (id, st) fits fits
483 { plainState_bufferWidth = plainState_bufferWidth st + w
485 k (id,newState) fits fits
487 -- | Like 'newline', but justify 'plainState_buffer' before.
488 newlineJustifyingPlain :: Outputable o => Plain o ()
489 newlineJustifyingPlain = Plain $ \() inh st ->
493 .> propagatePlain (plainState_breakIndent st)
497 indentPlain = Plain $ \a inh ->
499 (plainInh_indenting inh) a
500 inh{plainInh_justify=False}
501 newlinePlain = Plain $ \() inh st k ->
503 (if plainInh_justify inh
504 then justifyLinePlain inh st
508 { plainState_bufferStart = 0
509 , plainState_bufferWidth = 0
510 , plainState_buffer = mempty
512 propagatePlain breakIndent = Plain $ \() inh st1 k fits overflow ->
516 -- NOTE: the text after this newline overflows,
517 -- so propagate the overflow before this 'newline',
518 -- if and only if there is a 'breakspace' before this 'newline'
519 -- whose replacement by a 'newline' indents to a lower indent
520 -- than this 'newline''s indent.
521 -- Otherwise there is no point in propagating the overflow.
522 if breakIndent < plainInh_indent inh
530 PlainInh o -> PlainState o -> o
531 justifyLinePlain inh PlainState{..} =
532 case plainInh_width inh of
533 Nothing -> joinLinePlainChunk $ List.reverse plainState_buffer
535 if maxWidth < plainState_bufferStart
536 || maxWidth < plainInh_indent inh
537 then joinLinePlainChunk $ List.reverse plainState_buffer
539 let superfluousSpaces = Fold.foldr
542 PlainChunk_Ignored{} -> 0
543 PlainChunk_Word{} -> 0
544 PlainChunk_Spaces s -> s`minusNatural`(min 1 s))
545 0 plainState_buffer in
547 -- NOTE: cap the spaces at 1,
548 -- to let justifyWidth decide where to add spaces.
549 plainState_bufferWidth`minusNatural`superfluousSpaces in
551 -- NOTE: when minBufferWidth is not breakable,
552 -- the length of justification can be wider than
553 -- what remains to reach maxWidth.
555 maxWidth`minusNatural`plainState_bufferStart
557 let wordCount = countWordsPlain plainState_buffer in
558 unLine $ padLinePlainChunkInits justifyWidth $
559 (minBufferWidth,wordCount,List.reverse plainState_buffer)
561 -- | @('countWordsPlain' ps)@ returns the number of words in @(ps)@
562 -- clearly separated by spaces.
563 countWordsPlain :: [PlainChunk o] -> Natural
564 countWordsPlain = go False 0
566 go inWord acc = \case
568 PlainChunk_Word{}:xs ->
570 then go inWord acc xs
571 else go True (acc+1) xs
572 PlainChunk_Spaces s:xs
573 | s == 0 -> go inWord acc xs
574 | otherwise -> go False acc xs
575 PlainChunk_Ignored{}:xs -> go inWord acc xs
577 -- | @('justifyPadding' a b)@ returns the padding lengths
578 -- to reach @(a)@ in @(b)@ pads,
579 -- using the formula: @(a '==' m'*'(q '+' q'+'1) '+' ('r'-'m)'*'(q'+'1) '+' (b'-'r'-'m)'*'q)@
580 -- where @(q+1)@ and @(q)@ are the two padding lengths used and @(m = min (b-r) r)@.
582 -- A simple implementation of 'justifyPadding' could be:
584 -- 'justifyPadding' a b =
585 -- 'join' ('List.replicate' m [q,q'+'1])
586 -- <> ('List.replicate' (r'-'m) (q'+'1)
587 -- <> ('List.replicate' ((b'-'r)'-'m) q
589 -- (q,r) = a`divMod`b
592 justifyPadding :: Natural -> Natural -> [Natural]
593 justifyPadding a b = go r (b-r) -- NOTE: r >= 0 && b-r >= 0 due to 'divMod'
595 (q,r) = a`quotRemNatural`b
597 go 0 bmr = List.replicate (fromIntegral bmr) q -- when min (b-r) r == b-r
598 go rr 0 = List.replicate (fromIntegral rr) (q+1) -- when min (b-r) r == r
599 go rr bmr = q:(q+1) : go (rr`minusNatural`1) (bmr`minusNatural`1)
601 padLinePlainChunkInits ::
603 Width -> (Natural, Natural, [PlainChunk o]) -> Line o
604 padLinePlainChunkInits maxWidth (lineWidth,wordCount,line) = Line $
605 if maxWidth <= lineWidth
606 -- The gathered line reached or overreached the maxWidth,
607 -- hence no padding id needed.
609 -- The case maxWidth <= lineWidth && wordCount == 1
610 -- can happen if first word's length is < maxWidth
611 -- but second word's len is >= maxWidth.
612 then joinLinePlainChunk line
614 -- Share the missing spaces as evenly as possible
615 -- between the words of the line.
616 padLinePlainChunk line $ justifyPadding (maxWidth-lineWidth) (wordCount-1)
618 -- | Interleave 'PlainChunk's with 'Width's from 'justifyPadding'.
619 padLinePlainChunk :: Outputable o => [PlainChunk o] -> [Width] -> o
620 padLinePlainChunk = go
622 go (w:ws) lls@(l:ls) =
624 PlainChunk_Spaces _s -> repeatedChar (fromIntegral (l+1)) ' ' <> go ws ls
625 _ -> runPlainChunk w <> go ws lls
626 go (w:ws) [] = runPlainChunk w <> go ws []
630 sgrPlain :: Outputable o => [SGR] -> Plain o ()
631 sgrPlain sgr = Plain $ \() inh st k ->
632 if plainInh_justify inh
633 then k (id, st {plainState_buffer =
634 PlainChunk_Ignored (fromString (setSGRCode sgr)) :
637 else k ((fromString (setSGRCode sgr) <>), st)
639 instance Outputable o => Colorable16 (Plain o) where
640 reverse = plainSGR $ SetSwapForegroundBackground True
641 black = plainSGR $ SetColor Foreground Dull Black
642 red = plainSGR $ SetColor Foreground Dull Red
643 green = plainSGR $ SetColor Foreground Dull Green
644 yellow = plainSGR $ SetColor Foreground Dull Yellow
645 blue = plainSGR $ SetColor Foreground Dull Blue
646 magenta = plainSGR $ SetColor Foreground Dull Magenta
647 cyan = plainSGR $ SetColor Foreground Dull Cyan
648 white = plainSGR $ SetColor Foreground Dull White
649 blacker = plainSGR $ SetColor Foreground Vivid Black
650 redder = plainSGR $ SetColor Foreground Vivid Red
651 greener = plainSGR $ SetColor Foreground Vivid Green
652 yellower = plainSGR $ SetColor Foreground Vivid Yellow
653 bluer = plainSGR $ SetColor Foreground Vivid Blue
654 magentaer = plainSGR $ SetColor Foreground Vivid Magenta
655 cyaner = plainSGR $ SetColor Foreground Vivid Cyan
656 whiter = plainSGR $ SetColor Foreground Vivid White
657 onBlack = plainSGR $ SetColor Background Dull Black
658 onRed = plainSGR $ SetColor Background Dull Red
659 onGreen = plainSGR $ SetColor Background Dull Green
660 onYellow = plainSGR $ SetColor Background Dull Yellow
661 onBlue = plainSGR $ SetColor Background Dull Blue
662 onMagenta = plainSGR $ SetColor Background Dull Magenta
663 onCyan = plainSGR $ SetColor Background Dull Cyan
664 onWhite = plainSGR $ SetColor Background Dull White
665 onBlacker = plainSGR $ SetColor Background Vivid Black
666 onRedder = plainSGR $ SetColor Background Vivid Red
667 onGreener = plainSGR $ SetColor Background Vivid Green
668 onYellower = plainSGR $ SetColor Background Vivid Yellow
669 onBluer = plainSGR $ SetColor Background Vivid Blue
670 onMagentaer = plainSGR $ SetColor Background Vivid Magenta
671 onCyaner = plainSGR $ SetColor Background Vivid Cyan
672 onWhiter = plainSGR $ SetColor Background Vivid White
673 instance Outputable o => Decorable (Plain o) where
674 bold = plainSGR $ SetConsoleIntensity BoldIntensity
675 underline = plainSGR $ SetUnderlining SingleUnderline
676 italic = plainSGR $ SetItalicized True
678 plainSGR :: Outputable o => SGR -> Plain o a -> Plain o a
679 plainSGR newSGR p = before .> middle <. after
681 before = Plain $ \() inh st k ->
682 let o = fromString $ setSGRCode [newSGR] in
683 if plainInh_justify inh
685 { plainState_buffer =
686 PlainChunk_Ignored o :
690 middle = Plain $ \a inh ->
691 unPlain p a inh{plainInh_sgr=newSGR:plainInh_sgr inh}
692 after = Plain $ \() inh st k ->
693 let o = fromString $ setSGRCode $ Reset : List.reverse (plainInh_sgr inh) in
694 if plainInh_justify inh
696 { plainState_buffer =
697 PlainChunk_Ignored o :