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)