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)