1 {-# LANGUAGE NoMonomorphismRestriction #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE UndecidableInstances #-}
4 module Symantic.Plaintext.Writer 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
31 import Symantic.Plaintext.Classes hiding (char)
32 import Symantic.Plaintext.Output
35 -- | Church encoded for performance concerns.
36 -- Kind like 'ParsecT' in @megaparsec@ but a little bit different
37 -- due to the use of 'WriterFit' for implementing 'breakingSpace' correctly
38 -- when in the left hand side of ('<.>').
39 -- Prepending is done using continuation, like in a difference list.
40 newtype Writer (o::Type) a = Writer
42 {-curr-}WriterInh o ->
43 {-curr-}WriterState o ->
44 {-ok-}( ({-prepend-}(o->o), {-new-}WriterState o) -> WriterFit o) ->
46 -- NOTE: equivalent to:
47 -- ReaderT WriterInh (StateT (WriterState o) (Cont (WriterFit o))) (o->o)
50 runWriter :: Monoid o => Writer o a -> a -> o
55 {-k-}(\(px,_sx) fits _overflow ->
56 -- NOTE: if px fits, then appending mempty fits
61 instance Semigroup o => ProductFunctor (Writer o) where
62 x <.> y = Writer $ \(a,b) inh st k ->
63 unWriter x a inh st $ \(px,sx) ->
64 unWriter y b inh sx $ \(py,sy) ->
66 x .> y = Writer $ \b inh st k ->
67 unWriter x () inh st $ \(px,sx) ->
68 unWriter y b inh sx $ \(py,sy) ->
70 x <. y = Writer $ \a inh st k ->
71 unWriter x a inh st $ \(px,sx) ->
72 unWriter y () inh sx $ \(py,sy) ->
74 instance Emptyable (Writer o) where
75 empty = Writer $ \_a _inh st k -> k (id,st)
76 instance Outputable o => Repeatable (Writer o) where
77 many0 item = Writer $ \as ->
78 unWriter (concat ((`void` item) <$> as)) ()
79 many1 item = Writer $ \case
81 as -> unWriter (concat ((`void` item) <$> as)) ()
84 instance (Convertible String o, Outputable o) => IsString (Writer o ()) where
86 instance (Convertible String o, Outputable o) => Convertible String (Writer o ()) where
89 List.intersperse newline .
92 List.intersperse breakspace .
96 instance (Convertible T.Text o, Convertible Char o, Outputable o) => Convertible T.Text (Writer o ()) where
99 List.intersperse newline .
102 List.intersperse breakspace .
106 instance (Convertible TL.Text o, Convertible Char o, Outputable o) => Convertible TL.Text (Writer o ()) where
109 List.intersperse newline .
112 List.intersperse breakspace .
117 instance (Convertible String o, Outputable o) => Inferable Int (Writer o) where
118 infer = showWordWriter
119 instance (Convertible String o, Outputable o) => Inferable Natural (Writer o) where
120 infer = showWordWriter
121 instance (Convertible String o, Outputable o) => Inferable (Word String) (Writer o) where
122 infer = Writer $ ($ ()) . unWriter . wordWriter
123 instance (Convertible String o, Outputable o) => Inferable String (Writer o) where
124 infer = Writer $ ($ ()) . unWriter . fromString
125 instance (Convertible T.Text o, Convertible Char o, Outputable o) => Inferable T.Text (Writer o) where
126 infer = Writer $ ($ ()) . unWriter . convert
127 instance (Convertible TL.Text o, Convertible Char o, Outputable o) => Inferable TL.Text (Writer o) where
128 infer = Writer $ ($ ()) . unWriter . convert
129 instance Outputable o => Inferable Char (Writer o) where
130 infer = Writer $ \case
131 '\n' -> unWriter newline ()
132 ' ' -> unWriter breakspace ()
133 c -> unWriter (wordWriter (Word c)) ()
134 instance Outputable o => Inferable (Word Char) (Writer o) where
135 infer = Writer $ \c -> unWriter (wordWriter c) ()
138 Convertible String o =>
140 Inferable a (Writer o) => Writer o a
141 showWordWriter = Writer $
142 ($ ()) . unWriter . wordWriter .
145 -- ** Type 'WriterState'
146 data WriterState o = WriterState
147 { plainState_buffer :: ![WriterChunk o]
148 , plainState_bufferStart :: !Column
149 -- ^ The 'Column' from which the 'plainState_buffer'
151 , plainState_bufferWidth :: !Width
152 -- ^ The 'Width' of the 'plainState_buffer' so far.
153 , plainState_breakIndent :: !Indent
154 -- ^ The amount of 'Indent' added by 'breakspace'
155 -- that can be reached by breaking the 'space'
156 -- into a 'newlineJustifyingWriter'.
159 defWriterState :: WriterState o
160 defWriterState = WriterState
161 { plainState_buffer = mempty
162 , plainState_bufferStart = 0
163 , plainState_bufferWidth = 0
164 , plainState_breakIndent = 0
167 -- ** Type 'WriterInh'
168 data WriterInh o = WriterInh
169 { plainInh_width :: !(Maybe Column)
170 , plainInh_justify :: !Bool
171 , plainInh_indent :: !Indent
172 , plainInh_indenting :: !(Writer o ())
173 , plainInh_sgr :: ![SGR]
176 defWriterInh :: Monoid o => WriterInh o
177 defWriterInh = WriterInh
178 { plainInh_width = Nothing
179 , plainInh_justify = False
180 , plainInh_indent = 0
181 , plainInh_indenting = empty
185 -- ** Type 'WriterFit'
186 -- | Double continuation to qualify the returned document
187 -- as fitting or overflowing the given 'plainInh_width'.
188 -- It's like @('Bool',o)@ in a normal style
189 -- (a non continuation-passing-style).
192 {-overflow-}(o -> o) ->
195 -- ** Type 'WriterChunk'
197 = WriterChunk_Ignored !o
198 -- ^ Ignored by the justification but kept in place.
199 -- Used for instance to put ANSI sequences.
200 | WriterChunk_Word !(Word o)
201 | WriterChunk_Spaces !Width
202 -- ^ 'spaces' preserved to be interleaved
203 -- correctly with 'WriterChunk_Ignored'.
204 instance Show o => Show (WriterChunk o) where
208 WriterChunk_Ignored o ->
211 WriterChunk_Word (Word o) ->
214 WriterChunk_Spaces s ->
217 instance Lengthable o => Lengthable (WriterChunk o) where
219 WriterChunk_Ignored{} -> 0
220 WriterChunk_Word o -> length o
221 WriterChunk_Spaces s -> s
223 WriterChunk_Ignored{} -> True
224 WriterChunk_Word o -> isEmpty o
225 WriterChunk_Spaces s -> s == 0
226 --instance From [SGR] o => From [SGR] (WriterChunk o) where
227 -- from sgr = WriterChunk_Ignored (from sgr)
229 runWriterChunk :: Outputable o => WriterChunk o -> o
230 runWriterChunk = \case
231 WriterChunk_Ignored o -> o
232 WriterChunk_Word (Word o) -> o
233 WriterChunk_Spaces s -> repeatedChar s ' '
235 instance Voidable (Writer o) where
236 void a p = Writer $ \() -> unWriter p a
237 instance (Convertible Char o, Outputable o) => Spaceable (Writer o) where
239 spaces n = Writer $ \() inh st@WriterState{..} k fits overflow ->
240 let newWidth = plainState_bufferStart + plainState_bufferWidth + n in
241 if plainInh_justify inh
244 { plainState_buffer =
245 case plainState_buffer of
246 WriterChunk_Spaces s:buf -> WriterChunk_Spaces (s+n):buf
247 buf -> WriterChunk_Spaces n:buf
248 , plainState_bufferWidth = plainState_bufferWidth + n
250 case plainInh_width inh of
251 Just maxWidth | maxWidth < newWidth ->
252 overflow $ k (id{-(o<>)-}, newState) fits overflow
253 _ -> k (id{-(o<>)-}, newState) fits overflow
256 { plainState_bufferWidth = plainState_bufferWidth + n
258 case plainInh_width inh of
259 Just maxWidth | maxWidth < newWidth ->
260 overflow $ k ((repeatedChar n ' ' <>), newState) fits fits
261 _ -> k ((repeatedChar n ' ' <>), newState) fits overflow
262 instance (Outputable o) => Newlineable (Writer o) where
263 -- | The default 'newline' does not justify 'plainState_buffer',
264 -- for that use 'newlineJustifyingWriter'.
265 newline = Writer $ \() inh st ->
269 <. propagateWriter (plainState_breakIndent st)
273 indentWriter = Writer $ \() inh ->
275 (plainInh_indenting inh)
276 () inh{plainInh_justify=False}
277 newlineWriter = Writer $ \() inh st k ->
279 (if plainInh_justify inh
280 then joinLineWriterChunk $ List.reverse $ plainState_buffer st
284 { plainState_bufferStart = 0
285 , plainState_bufferWidth = 0
286 , plainState_buffer = mempty
288 propagateWriter breakIndent = Writer $ \() inh st1 k fits overflow ->
292 -- NOTE: the text after this newline overflows,
293 -- so propagate the overflow before this 'newline',
294 -- if and only if there is a 'breakspace' before this 'newline'
295 -- whose replacement by a 'newline' indents to a lower indent
296 -- than this 'newline''s indent.
297 -- Otherwise there is no point in propagating the overflow.
298 if breakIndent < plainInh_indent inh
303 -- | Commit 'plainState_buffer' upto there, so that it won'o be justified.
304 flushlineWriter :: Outputable o => Writer o ()
305 flushlineWriter = Writer $ \() _inh st k ->
306 k( (joinLineWriterChunk (collapseWriterChunkSpaces <$> List.reverse (plainState_buffer st)) <>)
308 { plainState_bufferStart = plainState_bufferStart st + plainState_bufferWidth st
309 , plainState_bufferWidth = 0
310 , plainState_buffer = mempty
314 -- | Just concat 'WriterChunk's with no justification.
315 joinLineWriterChunk :: Outputable o => [WriterChunk o] -> o
316 joinLineWriterChunk = mconcat . (runWriterChunk <$>)
318 collapseWriterChunkSpaces :: WriterChunk o -> WriterChunk o
319 collapseWriterChunkSpaces = \case
320 WriterChunk_Spaces s -> WriterChunk_Spaces (if s > 0 then 1 else 0)
324 Lengthable i => Convertible i o => Outputable o =>
325 Word i -> Writer o ()
326 wordWriter inp = Writer $ \() inh st@WriterState{..} k fits overflow ->
327 let wordWidth = length inp in
328 let out = convert inp in
330 then k (id,st) fits overflow
332 let newBufferWidth = plainState_bufferWidth + wordWidth in
333 let newWidth = plainState_bufferStart + newBufferWidth in
334 if plainInh_justify inh
337 { plainState_buffer = WriterChunk_Word out : plainState_buffer
338 , plainState_bufferWidth = newBufferWidth
340 case plainInh_width inh of
341 Just maxWidth | maxWidth < newWidth ->
342 overflow $ k (id, newState) fits overflow
343 _ -> k (id, newState) fits overflow
346 { plainState_bufferWidth = newBufferWidth
348 case plainInh_width inh of
349 Just maxWidth | maxWidth < newWidth ->
350 overflow $ k ((unWord out <>), newState) fits fits
351 _ -> k ((unWord out <>), newState) fits overflow
353 instance (Convertible Char o, Outputable o) => Indentable (Writer o) where
354 align p = (flushlineWriter .>) $ Writer $ \a inh st ->
355 let col = plainState_bufferStart st + plainState_bufferWidth st in
357 { plainInh_indent = col
358 , plainInh_indenting =
359 if plainInh_indent inh <= col
361 plainInh_indenting inh .>
362 spaces (col`minusNatural`plainInh_indent inh)
365 setIndent o i p = Writer $ \a inh ->
367 { plainInh_indent = i
368 , plainInh_indenting = o
370 incrIndent o i p = Writer $ \a inh ->
372 { plainInh_indent = plainInh_indent inh + i
373 , plainInh_indenting = plainInh_indenting inh .> o
375 fill m p = Writer $ \a inh0 st0 ->
376 let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
377 let p1 = Writer $ \() inh1 st1 ->
378 let col = plainState_bufferStart st1 + plainState_bufferWidth st1 in
381 then spaces (maxCol`minusNatural`col)
385 unWriter (p <. p1) a inh0 st0
386 fillOrBreak m p = Writer $ \a inh0 st0 ->
387 let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
388 let p1 = Writer $ \() inh1 st1 ->
389 let col = plainState_bufferStart st1 + plainState_bufferWidth st1 in
391 (case col`compare`maxCol of
392 LT -> spaces (maxCol`minusNatural`col)
394 GT -> incrIndent (spaces m) m newline
397 unWriter (p <. p1) a inh0 st0
398 instance (Convertible Char o, Convertible String o, Outputable o) => Listable (Writer o) where
402 wordWriter (Word '-').>space.>flushlineWriter
404 -- .> flushlineWriter
410 , ( wordWriter (Word (show n))
411 .> wordWriter (Word '.') .> space
414 -- .> flushlineWriter
417 ) (Fold.length is, []) is
418 unorderedList li = intercalate_ newline $
419 wordWriter (Word '-') .> space .> flushlineWriter .> align li
420 orderedList li = Writer $ \as ->
421 unWriter (intercalate_ newline item)
424 item = Writer $ \(i::Natural, a) ->
427 .> wordWriter (Word '.') .> space
430 intercalate_ sep li = Writer $ \as ->
431 unWriter (concat (List.intersperse sep ((`void` li) <$> as))) ()
432 list_ opn sep cls li =
434 (opn .> intercalate_ (sep .> space) li <. cls)
435 (align $ opn .> space
436 .> intercalate_ (newline .> sep .> space) li
438 instance Outputable o => Justifiable (Writer o) where
439 justify p = (\x -> flushlineWriter .> x <. flushlineWriter) $ Writer $ \a inh ->
440 unWriter p a inh{plainInh_justify=True}
441 instance Outputable o => Wrappable (Writer o) where
442 setWidth w p = Writer $ \a inh ->
443 unWriter p a inh{plainInh_width=w}
444 breakpoint = Writer $ \() inh st k fits overflow ->
445 k(id, st{plainState_breakIndent = plainInh_indent inh})
447 {-overflow-}(\_r -> unWriter newlineJustifyingWriter () inh st k fits overflow)
448 breakspace = Writer $ \() inh st k fits overflow ->
449 k( if plainInh_justify inh then id else (char ' ' <>)
451 { plainState_buffer =
452 if plainInh_justify inh
453 then case plainState_buffer st of
454 WriterChunk_Spaces s:bs -> WriterChunk_Spaces (s+1):bs
455 bs -> WriterChunk_Spaces 1:bs
456 else plainState_buffer st
457 , plainState_bufferWidth = plainState_bufferWidth st + 1
458 , plainState_breakIndent = plainInh_indent inh
462 {-overflow-}(\_r -> unWriter newlineJustifyingWriter () inh st k fits overflow)
463 breakalt x y = Writer $ \a inh st k fits overflow ->
464 -- NOTE: breakalt must be y if and only if x does not fit,
465 -- hence the use of dummyK to limit the test
466 -- to overflows raised within x, and drop those raised after x.
467 unWriter x a inh st dummyK
468 {-fits-} (\_r -> unWriter x a inh st k fits overflow)
469 {-overflow-}(\_r -> unWriter y a inh st k fits overflow)
471 dummyK (px,_sx) fits _overflow =
472 -- NOTE: if px fits, then appending mempty fits
474 endline = Writer $ \() inh st k fits _overflow ->
475 let col = plainState_bufferStart st + plainState_bufferWidth st in
476 case plainInh_width inh >>= (`minusNaturalMaybe` col) of
477 Nothing -> k (id, st) fits fits
480 { plainState_bufferWidth = plainState_bufferWidth st + w
482 k (id,newState) fits fits
484 -- | Like 'newline', but justify 'plainState_buffer' before.
485 newlineJustifyingWriter :: Outputable o => Writer o ()
486 newlineJustifyingWriter = Writer $ \() inh st ->
490 .> propagateWriter (plainState_breakIndent st)
494 indentWriter = Writer $ \a inh ->
496 (plainInh_indenting inh) a
497 inh{plainInh_justify=False}
498 newlineWriter = Writer $ \() inh st k ->
500 (if plainInh_justify inh
501 then justifyLineWriter inh st
505 { plainState_bufferStart = 0
506 , plainState_bufferWidth = 0
507 , plainState_buffer = mempty
509 propagateWriter breakIndent = Writer $ \() inh st1 k fits overflow ->
513 -- NOTE: the text after this newline overflows,
514 -- so propagate the overflow before this 'newline',
515 -- if and only if there is a 'breakspace' before this 'newline'
516 -- whose replacement by a 'newline' indents to a lower indent
517 -- than this 'newline''s indent.
518 -- Otherwise there is no point in propagating the overflow.
519 if breakIndent < plainInh_indent inh
527 WriterInh o -> WriterState o -> o
528 justifyLineWriter inh WriterState{..} =
529 case plainInh_width inh of
530 Nothing -> joinLineWriterChunk $ List.reverse plainState_buffer
532 if maxWidth < plainState_bufferStart
533 || maxWidth < plainInh_indent inh
534 then joinLineWriterChunk $ List.reverse plainState_buffer
536 let superfluousSpaces = Fold.foldr
539 WriterChunk_Ignored{} -> 0
540 WriterChunk_Word{} -> 0
541 WriterChunk_Spaces s -> s`minusNatural`(min 1 s))
542 0 plainState_buffer in
544 -- NOTE: cap the spaces at 1,
545 -- to let justifyWidth decide where to add spaces.
546 plainState_bufferWidth`minusNatural`superfluousSpaces in
548 -- NOTE: when minBufferWidth is not breakable,
549 -- the length of justification can be wider than
550 -- what remains to reach maxWidth.
552 maxWidth`minusNatural`plainState_bufferStart
554 let wordCount = countWordsWriter plainState_buffer in
555 unLine $ padLineWriterChunkInits justifyWidth $
556 (minBufferWidth,wordCount,List.reverse plainState_buffer)
558 -- | @('countWordsWriter' ps)@ returns the number of words in @(ps)@
559 -- clearly separated by spaces.
560 countWordsWriter :: [WriterChunk o] -> Natural
561 countWordsWriter = go False 0
563 go inWord acc = \case
565 WriterChunk_Word{}:xs ->
567 then go inWord acc xs
568 else go True (acc+1) xs
569 WriterChunk_Spaces s:xs
570 | s == 0 -> go inWord acc xs
571 | otherwise -> go False acc xs
572 WriterChunk_Ignored{}:xs -> go inWord acc xs
574 -- | @('justifyPadding' a b)@ returns the padding lengths
575 -- to reach @(a)@ in @(b)@ pads,
576 -- using the formula: @(a '==' m'*'(q '+' q'+'1) '+' ('r'-'m)'*'(q'+'1) '+' (b'-'r'-'m)'*'q)@
577 -- where @(q+1)@ and @(q)@ are the two padding lengths used and @(m = min (b-r) r)@.
579 -- A simple implementation of 'justifyPadding' could be:
581 -- 'justifyPadding' a b =
582 -- 'join' ('List.replicate' m [q,q'+'1])
583 -- <> ('List.replicate' (r'-'m) (q'+'1)
584 -- <> ('List.replicate' ((b'-'r)'-'m) q
586 -- (q,r) = a`divMod`b
589 justifyPadding :: Natural -> Natural -> [Natural]
590 justifyPadding a b = go r (b-r) -- NOTE: r >= 0 && b-r >= 0 due to 'divMod'
592 (q,r) = a`quotRemNatural`b
593 go 0 bmr = List.replicate (fromIntegral bmr) q -- when min (b-r) r == b-r
594 go rr 0 = List.replicate (fromIntegral rr) (q+1) -- when min (b-r) r == r
595 go rr bmr = q:(q+1) : go (rr`minusNatural`1) (bmr`minusNatural`1)
597 padLineWriterChunkInits ::
599 Width -> (Natural, Natural, [WriterChunk o]) -> Line o
600 padLineWriterChunkInits maxWidth (lineWidth,wordCount,line) = Line $
601 if maxWidth <= lineWidth
602 -- The gathered line reached or overreached the maxWidth,
603 -- hence no padding id needed.
605 -- The case maxWidth <= lineWidth && wordCount == 1
606 -- can happen if first word's length is < maxWidth
607 -- but second word's len is >= maxWidth.
608 then joinLineWriterChunk line
610 -- Share the missing spaces as evenly as possible
611 -- between the words of the line.
612 padLineWriterChunk line $ justifyPadding (maxWidth-lineWidth) (wordCount-1)
614 -- | Interleave 'WriterChunk's with 'Width's from 'justifyPadding'.
615 padLineWriterChunk :: Outputable o => [WriterChunk o] -> [Width] -> o
616 padLineWriterChunk = go
618 go (w:ws) lls@(l:ls) =
620 WriterChunk_Spaces _s -> repeatedChar (fromIntegral (l+1)) ' ' <> go ws ls
621 _ -> runWriterChunk w <> go ws lls
622 go (w:ws) [] = runWriterChunk w <> go ws []
626 sgrWriter :: Outputable o => [SGR] -> Writer o ()
627 sgrWriter sgr = Writer $ \() inh st k ->
628 if plainInh_justify inh
629 then k (id, st {plainState_buffer =
630 WriterChunk_Ignored (fromString (setSGRCode sgr)) :
633 else k ((fromString (setSGRCode sgr) <>), st)
635 instance Outputable o => Colorable16 (Writer o) where
636 reverse = plainSGR $ SetSwapForegroundBackground True
637 black = plainSGR $ SetColor Foreground Dull Black
638 red = plainSGR $ SetColor Foreground Dull Red
639 green = plainSGR $ SetColor Foreground Dull Green
640 yellow = plainSGR $ SetColor Foreground Dull Yellow
641 blue = plainSGR $ SetColor Foreground Dull Blue
642 magenta = plainSGR $ SetColor Foreground Dull Magenta
643 cyan = plainSGR $ SetColor Foreground Dull Cyan
644 white = plainSGR $ SetColor Foreground Dull White
645 blacker = plainSGR $ SetColor Foreground Vivid Black
646 redder = plainSGR $ SetColor Foreground Vivid Red
647 greener = plainSGR $ SetColor Foreground Vivid Green
648 yellower = plainSGR $ SetColor Foreground Vivid Yellow
649 bluer = plainSGR $ SetColor Foreground Vivid Blue
650 magentaer = plainSGR $ SetColor Foreground Vivid Magenta
651 cyaner = plainSGR $ SetColor Foreground Vivid Cyan
652 whiter = plainSGR $ SetColor Foreground Vivid White
653 onBlack = plainSGR $ SetColor Background Dull Black
654 onRed = plainSGR $ SetColor Background Dull Red
655 onGreen = plainSGR $ SetColor Background Dull Green
656 onYellow = plainSGR $ SetColor Background Dull Yellow
657 onBlue = plainSGR $ SetColor Background Dull Blue
658 onMagenta = plainSGR $ SetColor Background Dull Magenta
659 onCyan = plainSGR $ SetColor Background Dull Cyan
660 onWhite = plainSGR $ SetColor Background Dull White
661 onBlacker = plainSGR $ SetColor Background Vivid Black
662 onRedder = plainSGR $ SetColor Background Vivid Red
663 onGreener = plainSGR $ SetColor Background Vivid Green
664 onYellower = plainSGR $ SetColor Background Vivid Yellow
665 onBluer = plainSGR $ SetColor Background Vivid Blue
666 onMagentaer = plainSGR $ SetColor Background Vivid Magenta
667 onCyaner = plainSGR $ SetColor Background Vivid Cyan
668 onWhiter = plainSGR $ SetColor Background Vivid White
669 instance Outputable o => Decorable (Writer o) where
670 bold = plainSGR $ SetConsoleIntensity BoldIntensity
671 underline = plainSGR $ SetUnderlining SingleUnderline
672 italic = plainSGR $ SetItalicized True
674 plainSGR :: Outputable o => SGR -> Writer o a -> Writer o a
675 plainSGR newSGR p = before .> middle <. after
677 before = Writer $ \() inh st k ->
678 let o = fromString $ setSGRCode [newSGR] in
679 if plainInh_justify inh
681 { plainState_buffer =
682 WriterChunk_Ignored o :
686 middle = Writer $ \a inh ->
687 unWriter p a inh{plainInh_sgr=newSGR:plainInh_sgr inh}
688 after = Writer $ \() inh st k ->
689 let o = fromString $ setSGRCode $ Reset : List.reverse (plainInh_sgr inh) in
690 if plainInh_justify inh
692 { plainState_buffer =
693 WriterChunk_Ignored o :