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
  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.API
  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)