src/Symantic/Formatter/Plain.hs

   1 {-# LANGUAGE NoMonomorphismRestriction #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE UndecidableInstances #-}
   4 module Symantic.Formatter.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.Int (Int)
  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
  30
  31 import Symantic.Class
  32   ( Repeatable(..)
  33   )
  34 import Symantic.Formatter.Class
  35 import Symantic.Formatter.Output
  36
  37 -- * Type 'Plain'
  38 -- | Church encoded for performance concerns.
  39 -- Kind like 'ParsecT' in @megaparsec@ but a little bit different
  40 -- due to the use of 'PlainFit' for implementing 'breakingSpace' correctly
  41 -- when in the left hand side of ('<.>').
  42 -- Prepending is done using continuation, like in a difference list.
  43 newtype Plain (o::Type) a = Plain
  44   { unPlain :: a ->
  45      {-curr-}PlainInh o ->
  46      {-curr-}PlainState o ->
  47      {-ok-}( ({-prepend-}(o->o), {-new-}PlainState o) -> PlainFit o) ->
  48      PlainFit o
  49      -- NOTE: equivalent to:
  50      -- ReaderT PlainInh (StateT (PlainState o) (Cont (PlainFit o))) (o->o)
  51   }
  52
  53 instance Semigroup o => ProductFunctor (Plain o) where
  54   x <.> y = Plain $ \(a,b) inh st k ->
  55     unPlain x a inh st $ \(px,sx) ->
  56       unPlain y b inh sx $ \(py,sy) ->
  57         k (px.py, sy)
  58   x .> y = Plain $ \b inh st k ->
  59     unPlain x () inh st $ \(px,sx) ->
  60       unPlain y b inh sx $ \(py,sy) ->
  61         k (px.py, sy)
  62   x <. y = Plain $ \a inh st k ->
  63     unPlain x a inh st $ \(px,sx) ->
  64       unPlain y () inh sx $ \(py,sy) ->
  65         k (px.py, sy)
  66 instance Emptyable (Plain o) where
  67   empty = Plain $ \_a _inh st k -> k (id,st)
  68 instance Outputable o => Repeatable (Plain o) where
  69   many0 item = Plain $ \as ->
  70     unPlain (concat ((`void` item) <$> as)) ()
  71   many1 item = Plain $ \case
  72     [] -> error "many1"
  73     as -> unPlain (concat ((`void` item) <$> as)) ()
  74
  75 -- String
  76 instance (Convertible String o, Outputable o) => IsString (Plain o ()) where
  77   fromString = convert
  78 instance (Convertible String o, Outputable o) => Convertible String (Plain o ()) where
  79   convert =
  80     concat .
  81     List.intersperse newline .
  82     (
  83       concat .
  84       List.intersperse breakspace .
  85       (wordPlain <$>) .
  86       words <$>
  87     ) . lines
  88 instance (Convertible T.Text o, Convertible Char o, Outputable o) => Convertible T.Text (Plain o ()) where
  89   convert =
  90     concat .
  91     List.intersperse newline .
  92     (
  93       concat .
  94       List.intersperse breakspace .
  95       (wordPlain <$>) .
  96       words <$>
  97     ) . lines
  98 instance (Convertible TL.Text o, Convertible Char o, Outputable o) => Convertible TL.Text (Plain o ()) where
  99   convert =
 100     concat .
 101     List.intersperse newline .
 102     (
 103       concat .
 104       List.intersperse breakspace .
 105       (wordPlain <$>) .
 106       words <$>
 107     ) . lines
 108 --intersperse sep = concat . List.intersperse sep
 109 instance (Convertible String o, Outputable o) => Inferable Int (Plain o) where
 110   infer = showWordPlain
 111 instance (Convertible String o, Outputable o) => Inferable Natural (Plain o) where
 112   infer = showWordPlain
 113 instance (Convertible String o, Outputable o) => Inferable (Word String) (Plain o) where
 114   infer = Plain $ ($ ()) . unPlain . wordPlain
 115 instance (Convertible String o, Outputable o) => Inferable String (Plain o) where
 116   infer = Plain $ ($ ()) . unPlain . fromString
 117 instance (Convertible T.Text o, Convertible Char o, Outputable o) => Inferable T.Text (Plain o) where
 118   infer = Plain $ ($ ()) . unPlain . convert
 119 instance (Convertible TL.Text o, Convertible Char o, Outputable o) => Inferable TL.Text (Plain o) where
 120   infer = Plain $ ($ ()) . unPlain . convert
 121 instance Outputable o => Inferable Char (Plain o) where
 122   infer = Plain $ \case
 123     '\n' -> unPlain newline ()
 124     ' ' -> unPlain breakspace ()
 125     c -> unPlain (wordPlain (Word c)) ()
 126 instance Outputable o => Inferable (Word Char) (Plain o) where
 127   infer = Plain $ \c -> unPlain (wordPlain c) ()
 128 showWordPlain ::
 129   Show a =>
 130   Convertible String o =>
 131   Outputable o =>
 132   Inferable a (Plain o) => Plain o a
 133 showWordPlain = Plain $
 134   ($ ()) . unPlain . wordPlain .
 135   Word . show
 136
 137 runPlain :: Monoid o => Plain o a -> a -> o
 138 runPlain x a =
 139   unPlain x a
 140    defPlainInh
 141    defPlainState
 142    {-k-}(\(px,_sx) fits _overflow ->
 143     -- NOTE: if px fits, then appending mempty fits
 144     fits (px mempty) )
 145    {-fits-}id
 146    {-overflow-}id
 147
 148 -- ** Type 'PlainState'
 149 data PlainState o = PlainState
 150   { plainState_buffer :: ![PlainChunk o]
 151   , plainState_bufferStart :: !Column
 152     -- ^ The 'Column' from which the 'plainState_buffer'
 153     -- must be written.
 154   , plainState_bufferWidth :: !Width
 155     -- ^ The 'Width' of the 'plainState_buffer' so far.
 156   , plainState_breakIndent :: !Indent
 157     -- ^ The amount of 'Indent' added by 'breakspace'
 158     -- that can be reached by breaking the 'space'
 159     -- into a 'newlineJustifyingPlain'.
 160   } deriving (Show)
 161
 162 defPlainState :: PlainState o
 163 defPlainState = PlainState
 164   { plainState_buffer = mempty
 165   , plainState_bufferStart = 0
 166   , plainState_bufferWidth = 0
 167   , plainState_breakIndent = 0
 168   }
 169
 170 -- ** Type 'PlainInh'
 171 data PlainInh o = PlainInh
 172   {  plainInh_width :: !(Maybe Column)
 173   ,  plainInh_justify :: !Bool
 174   ,  plainInh_indent :: !Indent
 175   ,  plainInh_indenting :: !(Plain o ())
 176   ,  plainInh_sgr :: ![SGR]
 177   }
 178
 179 defPlainInh :: Monoid o => PlainInh o
 180 defPlainInh = PlainInh
 181   { plainInh_width = Nothing
 182   , plainInh_justify = False
 183   , plainInh_indent = 0
 184   , plainInh_indenting = empty
 185   , plainInh_sgr = []
 186   }
 187
 188 -- ** Type 'PlainFit'
 189 -- | Double continuation to qualify the returned document
 190 -- as fitting or overflowing the given 'plainInh_width'.
 191 -- It's like @('Bool',o)@ in a normal style
 192 -- (a non continuation-passing-style).
 193 type PlainFit o =
 194   {-fits-}(o -> o) ->
 195   {-overflow-}(o -> o) ->
 196   o
 197
 198 -- ** Type 'PlainChunk'
 199 data PlainChunk o
 200   =  PlainChunk_Ignored !o
 201      -- ^ Ignored by the justification but kept in place.
 202      -- Used for instance to put ANSI sequences.
 203   |  PlainChunk_Word !(Word o)
 204   |  PlainChunk_Spaces !Width
 205      -- ^ 'spaces' preserved to be interleaved
 206      -- correctly with 'PlainChunk_Ignored'.
 207 instance Show o => Show (PlainChunk o) where
 208   showsPrec p x =
 209     showParen (p>10) $
 210     case x of
 211       PlainChunk_Ignored o ->
 212         showString "Z " .
 213         showsPrec 11 o
 214       PlainChunk_Word (Word o) ->
 215         showString "W " .
 216         showsPrec 11 o
 217       PlainChunk_Spaces s ->
 218         showString "S " .
 219         showsPrec 11 s
 220 instance Lengthable o => Lengthable (PlainChunk o) where
 221   length = \case
 222     PlainChunk_Ignored{} -> 0
 223     PlainChunk_Word o -> length o
 224     PlainChunk_Spaces s -> s
 225   isEmpty = \case
 226     PlainChunk_Ignored{} -> True
 227     PlainChunk_Word o -> isEmpty o
 228     PlainChunk_Spaces s -> s == 0
 229 --instance From [SGR] o => From [SGR] (PlainChunk o) where
 230 --  from sgr = PlainChunk_Ignored (from sgr)
 231
 232 runPlainChunk :: Outputable o => PlainChunk o -> o
 233 runPlainChunk = \case
 234   PlainChunk_Ignored o -> o
 235   PlainChunk_Word (Word o) -> o
 236   PlainChunk_Spaces s -> repeatedChar s ' '
 237
 238 instance Voidable (Plain o) where
 239   void a p = Plain $ \() -> unPlain p a
 240 instance (Convertible Char o, Outputable o) => Spaceable (Plain o) where
 241   space = spaces 1
 242   spaces n = Plain $ \() inh st@PlainState{..} k fits overflow ->
 243     let newWidth = plainState_bufferStart + plainState_bufferWidth + n in
 244     if plainInh_justify inh
 245     then
 246       let newState = st
 247            { plainState_buffer =
 248                case plainState_buffer of
 249                  PlainChunk_Spaces s:buf -> PlainChunk_Spaces (s+n):buf
 250                  buf -> PlainChunk_Spaces n:buf
 251            , plainState_bufferWidth = plainState_bufferWidth + n
 252            } in
 253       case plainInh_width inh of
 254         Just maxWidth | maxWidth < newWidth ->
 255          overflow $ k (id{-(o<>)-}, newState) fits overflow
 256         _ -> k (id{-(o<>)-}, newState) fits overflow
 257     else
 258       let newState = st
 259            { plainState_bufferWidth = plainState_bufferWidth + n
 260            } in
 261       case plainInh_width inh of
 262         Just maxWidth | maxWidth < newWidth ->
 263           overflow $ k ((repeatedChar n ' ' <>), newState) fits fits
 264         _ -> k ((repeatedChar n ' ' <>), newState) fits overflow
 265 instance (Outputable o) => Newlineable (Plain o) where
 266   -- | The default 'newline' does not justify 'plainState_buffer',
 267   -- for that use 'newlineJustifyingPlain'.
 268   newline = Plain $ \() inh st ->
 269     unPlain
 270      (  newlinePlain
 271      <. indentPlain
 272      <. propagatePlain (plainState_breakIndent st)
 273      <. flushlinePlain
 274      ) () inh st
 275     where
 276     indentPlain = Plain $ \() inh ->
 277       unPlain
 278        (plainInh_indenting inh)
 279        () inh{plainInh_justify=False}
 280     newlinePlain = Plain $ \() inh st k ->
 281       k (\next ->
 282         (if plainInh_justify inh
 283           then joinLinePlainChunk $ List.reverse $ plainState_buffer st
 284           else mempty
 285         )<>nl<>next
 286        , st
 287        { plainState_bufferStart = 0
 288        , plainState_bufferWidth = 0
 289        , plainState_buffer      = mempty
 290        })
 291     propagatePlain breakIndent = Plain $ \() inh st1 k fits overflow ->
 292       k (id,st1)
 293        fits
 294        {-overflow-}(
 295         -- NOTE: the text after this newline overflows,
 296         -- so propagate the overflow before this 'newline',
 297         -- if and only if there is a 'breakspace' before this 'newline'
 298         -- whose replacement by a 'newline' indents to a lower indent
 299         -- than this 'newline''s indent.
 300         -- Otherwise there is no point in propagating the overflow.
 301         if breakIndent < plainInh_indent inh
 302         then overflow
 303         else fits
 304        )
 305
 306 -- | Commit 'plainState_buffer' upto there, so that it won'o be justified.
 307 flushlinePlain :: Outputable o => Plain o ()
 308 flushlinePlain = Plain $ \() _inh st k ->
 309   k( (joinLinePlainChunk (collapsePlainChunkSpaces <$> List.reverse (plainState_buffer st)) <>)
 310    , st
 311      { plainState_bufferStart = plainState_bufferStart st + plainState_bufferWidth st
 312      , plainState_bufferWidth = 0
 313      , plainState_buffer      = mempty
 314      }
 315    )
 316
 317 -- | Just concat 'PlainChunk's with no justification.
 318 joinLinePlainChunk :: Outputable o => [PlainChunk o] -> o
 319 joinLinePlainChunk = mconcat . (runPlainChunk <$>)
 320
 321 collapsePlainChunkSpaces :: PlainChunk o -> PlainChunk o
 322 collapsePlainChunkSpaces = \case
 323   PlainChunk_Spaces s -> PlainChunk_Spaces (if s > 0 then 1 else 0)
 324   x -> x
 325
 326 wordPlain ::
 327   Lengthable i => Convertible i o => Outputable o =>
 328   Word i -> Plain o ()
 329 wordPlain inp = Plain $ \() inh st@PlainState{..} k fits overflow ->
 330   let wordWidth = length inp in
 331   let out = convert inp in
 332   if wordWidth <= 0
 333   then k (id,st) fits overflow
 334   else
 335     let newBufferWidth = plainState_bufferWidth + wordWidth in
 336     let newWidth = plainState_bufferStart + newBufferWidth in
 337     if plainInh_justify inh
 338     then
 339       let newState = st
 340            { plainState_buffer = PlainChunk_Word out : plainState_buffer
 341            , plainState_bufferWidth = newBufferWidth
 342            } in
 343       case plainInh_width inh of
 344         Just maxWidth | maxWidth < newWidth ->
 345          overflow $ k (id, newState) fits overflow
 346         _ -> k (id, newState) fits overflow
 347     else
 348       let newState = st
 349            { plainState_bufferWidth = newBufferWidth
 350            } in
 351       case plainInh_width inh of
 352         Just maxWidth | maxWidth < newWidth ->
 353          overflow $ k ((unWord out <>), newState) fits fits
 354         _ -> k ((unWord out <>), newState) fits overflow
 355
 356 instance (Convertible Char o, Outputable o) => Indentable (Plain o) where
 357   align p = (flushlinePlain .>) $ Plain $ \a inh st ->
 358     let col = plainState_bufferStart st + plainState_bufferWidth st in
 359     unPlain p a inh
 360      { plainInh_indent    = col
 361      , plainInh_indenting =
 362       if plainInh_indent inh <= col
 363       then
 364         plainInh_indenting inh .>
 365         spaces (col`minusNatural`plainInh_indent inh)
 366       else spaces col
 367      } st
 368   setIndent o i p = Plain $ \a inh ->
 369     unPlain p a inh
 370      { plainInh_indent    = i
 371      , plainInh_indenting = o
 372      }
 373   incrIndent o i p = Plain $ \a inh ->
 374     unPlain p a inh
 375      { plainInh_indent    = plainInh_indent inh + i
 376      , plainInh_indenting = plainInh_indenting inh .> o
 377      }
 378   fill m p = Plain $ \a inh0 st0 ->
 379     let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
 380     let p1 = Plain $ \() inh1 st1 ->
 381           let col = plainState_bufferStart st1 + plainState_bufferWidth st1 in
 382           unPlain
 383            (if col <= maxCol
 384             then spaces (maxCol`minusNatural`col)
 385             else empty)
 386            () inh1 st1
 387     in
 388     unPlain (p <. p1) a inh0 st0
 389   fillOrBreak m p = Plain $ \a inh0 st0 ->
 390     let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
 391     let p1 = Plain $ \() inh1 st1 ->
 392           let col = plainState_bufferStart st1 + plainState_bufferWidth st1 in
 393           unPlain
 394            (case col`compare`maxCol of
 395              LT -> spaces (maxCol`minusNatural`col)
 396              EQ -> empty
 397              GT -> incrIndent (spaces m) m newline
 398            ) () inh1 st1
 399     in
 400     unPlain (p <. p1) a inh0 st0
 401 instance (Convertible Char o, Convertible String o, Outputable o) => Listable (Plain o) where
 402   ul is =
 403     catV $
 404       (<$> is) $ \i ->
 405         wordPlain (Word '-').>space.>flushlinePlain
 406         .> align i
 407         -- .> flushlinePlain
 408   ol is =
 409     catV $ Tuple.snd $
 410       Fold.foldr
 411        (\o (n, acc) ->
 412          ( pred n
 413          , ( wordPlain (Word (show n))
 414            .> wordPlain (Word '.') .> space
 415            .> flushlinePlain
 416            .> align o
 417            -- .> flushlinePlain
 418            ) : acc
 419          )
 420        ) (Fold.length is, []) is
 421   unorderedList li = intercalate_ newline $
 422     wordPlain (Word '-') .> space .> flushlinePlain .> align li
 423   orderedList li = Plain $ \as ->
 424     unPlain (intercalate_ newline item)
 425      (List.zip [1..] as)
 426     where
 427     item = Plain $ \(i::Natural, a) ->
 428       ($ a) $ unPlain $
 429       void i natural
 430       .> wordPlain (Word '.') .> space
 431       .> flushlinePlain
 432       .> align li
 433   intercalate_ sep li = Plain $ \as ->
 434     unPlain (concat (List.intersperse sep ((`void` li) <$> as))) ()
 435   list_ opn sep cls li =
 436     breakalt
 437      (opn .> intercalate_ (sep .> space) li <. cls)
 438      (align $ opn .> space
 439        .> intercalate_ (newline .> sep .> space) li
 440        <. newline <. cls)
 441 instance Outputable o => Justifiable (Plain o) where
 442   justify p = (\x -> flushlinePlain .> x <. flushlinePlain) $ Plain $ \a inh ->
 443     unPlain p a inh{plainInh_justify=True}
 444 instance Outputable o => Wrappable (Plain o) where
 445   setWidth w p = Plain $ \a inh ->
 446     unPlain p a inh{plainInh_width=w}
 447   breakpoint = Plain $ \() inh st k fits overflow ->
 448     k(id, st{plainState_breakIndent = plainInh_indent inh})
 449      fits
 450      {-overflow-}(\_r -> unPlain newlineJustifyingPlain () inh st k fits overflow)
 451   breakspace = Plain $ \() inh st k fits overflow ->
 452     k( if plainInh_justify inh then id else (char ' ' <>)
 453      , st
 454        { plainState_buffer =
 455         if plainInh_justify inh
 456         then case plainState_buffer st of
 457            PlainChunk_Spaces s:bs -> PlainChunk_Spaces (s+1):bs
 458            bs -> PlainChunk_Spaces 1:bs
 459         else plainState_buffer st
 460        , plainState_bufferWidth = plainState_bufferWidth st + 1
 461        , plainState_breakIndent = plainInh_indent inh
 462        }
 463      )
 464      fits
 465      {-overflow-}(\_r -> unPlain newlineJustifyingPlain () inh st k fits overflow)
 466   breakalt x y = Plain $ \a inh st k fits overflow ->
 467     -- NOTE: breakalt must be y if and only if x does not fit,
 468     -- hence the use of dummyK to limit the test
 469     -- to overflows raised within x, and drop those raised after x.
 470     unPlain x a inh st dummyK
 471      {-fits-}    (\_r -> unPlain x a inh st k fits overflow)
 472      {-overflow-}(\_r -> unPlain y a inh st k fits overflow)
 473     where
 474     dummyK (px,_sx) fits _overflow =
 475       -- NOTE: if px fits, then appending mempty fits
 476       fits (px mempty)
 477   endline = Plain $ \() inh st k fits _overflow ->
 478     let col = plainState_bufferStart st + plainState_bufferWidth st in
 479     case plainInh_width inh >>= (`minusNaturalMaybe` col) of
 480      Nothing -> k (id, st) fits fits
 481      Just w ->
 482       let newState = st
 483            { plainState_bufferWidth = plainState_bufferWidth st + w
 484            } in
 485       k (id,newState) fits fits
 486
 487 -- | Like 'newline', but justify 'plainState_buffer' before.
 488 newlineJustifyingPlain :: Outputable o => Plain o ()
 489 newlineJustifyingPlain = Plain $ \() inh st ->
 490   unPlain
 491    (  newlinePlain
 492    .> indentPlain
 493    .> propagatePlain (plainState_breakIndent st)
 494    <. flushlinePlain
 495    ) () inh st
 496   where
 497   indentPlain = Plain $ \a inh ->
 498     unPlain
 499      (plainInh_indenting inh) a
 500      inh{plainInh_justify=False}
 501   newlinePlain = Plain $ \() inh st k ->
 502     k (\next ->
 503       (if plainInh_justify inh
 504         then justifyLinePlain inh st
 505         else mempty
 506       )<>nl<>next
 507      , st
 508      { plainState_bufferStart = 0
 509      , plainState_bufferWidth = 0
 510      , plainState_buffer      = mempty
 511      })
 512   propagatePlain breakIndent = Plain $ \() inh st1 k fits overflow ->
 513     k (id,st1)
 514      fits
 515      {-overflow-}(
 516       -- NOTE: the text after this newline overflows,
 517       -- so propagate the overflow before this 'newline',
 518       -- if and only if there is a 'breakspace' before this 'newline'
 519       -- whose replacement by a 'newline' indents to a lower indent
 520       -- than this 'newline''s indent.
 521       -- Otherwise there is no point in propagating the overflow.
 522       if breakIndent < plainInh_indent inh
 523       then overflow
 524       else fits
 525      )
 526
 527 -- * Justifying
 528 justifyLinePlain ::
 529   Outputable o =>
 530   PlainInh o -> PlainState o -> o
 531 justifyLinePlain inh PlainState{..} =
 532   case plainInh_width inh of
 533    Nothing -> joinLinePlainChunk $ List.reverse plainState_buffer
 534    Just maxWidth ->
 535     if maxWidth < plainState_bufferStart
 536     || maxWidth < plainInh_indent inh
 537     then joinLinePlainChunk $ List.reverse plainState_buffer
 538     else
 539       let superfluousSpaces = Fold.foldr
 540            (\c acc ->
 541             acc + case c of
 542              PlainChunk_Ignored{} -> 0
 543              PlainChunk_Word{} -> 0
 544              PlainChunk_Spaces s -> s`minusNatural`(min 1 s))
 545            0 plainState_buffer in
 546       let minBufferWidth =
 547             -- NOTE: cap the spaces at 1,
 548             -- to let justifyWidth decide where to add spaces.
 549             plainState_bufferWidth`minusNatural`superfluousSpaces in
 550       let justifyWidth =
 551             -- NOTE: when minBufferWidth is not breakable,
 552             -- the length of justification can be wider than
 553             -- what remains to reach maxWidth.
 554             max minBufferWidth $
 555               maxWidth`minusNatural`plainState_bufferStart
 556       in
 557       let wordCount = countWordsPlain plainState_buffer in
 558       unLine $ padLinePlainChunkInits justifyWidth $
 559        (minBufferWidth,wordCount,List.reverse plainState_buffer)
 560
 561 -- | @('countWordsPlain' ps)@ returns the number of words in @(ps)@
 562 -- clearly separated by spaces.
 563 countWordsPlain :: [PlainChunk o] -> Natural
 564 countWordsPlain = go False 0
 565  where
 566   go inWord acc = \case
 567    [] -> acc
 568    PlainChunk_Word{}:xs ->
 569     if inWord
 570     then go inWord acc xs
 571     else go True (acc+1) xs
 572    PlainChunk_Spaces s:xs
 573     | s == 0    -> go inWord acc xs
 574     | otherwise -> go False acc xs
 575    PlainChunk_Ignored{}:xs -> go inWord acc xs
 576
 577 -- | @('justifyPadding' a b)@ returns the padding lengths
 578 -- to reach @(a)@ in @(b)@ pads,
 579 -- using the formula: @(a '==' m'*'(q '+' q'+'1) '+' ('r'-'m)'*'(q'+'1) '+' (b'-'r'-'m)'*'q)@
 580 -- where @(q+1)@ and @(q)@ are the two padding lengths used and @(m = min (b-r) r)@.
 581 --
 582 -- A simple implementation of 'justifyPadding' could be:
 583 -- @
 584 -- 'justifyPadding' a b =
 585 --   'join' ('List.replicate' m [q,q'+'1])
 586 --   <> ('List.replicate' (r'-'m) (q'+'1)
 587 --   <> ('List.replicate' ((b'-'r)'-'m) q
 588 --   where
 589 --   (q,r) = a`divMod`b
 590 --   m = 'min' (b-r) r
 591 -- @
 592 justifyPadding :: Natural -> Natural -> [Natural]
 593 justifyPadding a b = go r (b-r) -- NOTE: r >= 0 && b-r >= 0 due to 'divMod'
 594   where
 595   (q,r) = a`quotRemNatural`b
 596
 597   go 0  bmr = List.replicate (fromIntegral bmr) q    -- when min (b-r) r == b-r
 598   go rr 0   = List.replicate (fromIntegral rr) (q+1) -- when min (b-r) r == r
 599   go rr bmr = q:(q+1) : go (rr`minusNatural`1) (bmr`minusNatural`1)
 600
 601 padLinePlainChunkInits ::
 602  Outputable o =>
 603  Width -> (Natural, Natural, [PlainChunk o]) -> Line o
 604 padLinePlainChunkInits maxWidth (lineWidth,wordCount,line) = Line $
 605   if maxWidth <= lineWidth
 606     -- The gathered line reached or overreached the maxWidth,
 607     -- hence no padding id needed.
 608   || wordCount <= 1
 609     -- The case maxWidth <= lineWidth && wordCount == 1
 610     -- can happen if first word's length is < maxWidth
 611     -- but second word's len is >= maxWidth.
 612   then joinLinePlainChunk line
 613   else
 614     -- Share the missing spaces as evenly as possible
 615     -- between the words of the line.
 616     padLinePlainChunk line $ justifyPadding (maxWidth-lineWidth) (wordCount-1)
 617
 618 -- | Interleave 'PlainChunk's with 'Width's from 'justifyPadding'.
 619 padLinePlainChunk :: Outputable o => [PlainChunk o] -> [Width] -> o
 620 padLinePlainChunk = go
 621   where
 622   go (w:ws) lls@(l:ls) =
 623     case w of
 624       PlainChunk_Spaces _s -> repeatedChar (fromIntegral (l+1)) ' ' <> go ws ls
 625       _ -> runPlainChunk w <> go ws lls
 626   go (w:ws) [] = runPlainChunk w <> go ws []
 627   go [] _ls = mempty
 628
 629
 630 sgrPlain :: Outputable o => [SGR] -> Plain o ()
 631 sgrPlain sgr = Plain $ \() inh st k ->
 632   if plainInh_justify inh
 633   then k (id, st {plainState_buffer =
 634     PlainChunk_Ignored (fromString (setSGRCode sgr)) :
 635     plainState_buffer st
 636   })
 637   else k ((fromString (setSGRCode sgr) <>), st)
 638
 639 instance Outputable o => Colorable16 (Plain o) where
 640   reverse     = plainSGR $ SetSwapForegroundBackground True
 641   black       = plainSGR $ SetColor Foreground Dull  Black
 642   red         = plainSGR $ SetColor Foreground Dull  Red
 643   green       = plainSGR $ SetColor Foreground Dull  Green
 644   yellow      = plainSGR $ SetColor Foreground Dull  Yellow
 645   blue        = plainSGR $ SetColor Foreground Dull  Blue
 646   magenta     = plainSGR $ SetColor Foreground Dull  Magenta
 647   cyan        = plainSGR $ SetColor Foreground Dull  Cyan
 648   white       = plainSGR $ SetColor Foreground Dull  White
 649   blacker     = plainSGR $ SetColor Foreground Vivid Black
 650   redder      = plainSGR $ SetColor Foreground Vivid Red
 651   greener     = plainSGR $ SetColor Foreground Vivid Green
 652   yellower    = plainSGR $ SetColor Foreground Vivid Yellow
 653   bluer       = plainSGR $ SetColor Foreground Vivid Blue
 654   magentaer   = plainSGR $ SetColor Foreground Vivid Magenta
 655   cyaner      = plainSGR $ SetColor Foreground Vivid Cyan
 656   whiter      = plainSGR $ SetColor Foreground Vivid White
 657   onBlack     = plainSGR $ SetColor Background Dull  Black
 658   onRed       = plainSGR $ SetColor Background Dull  Red
 659   onGreen     = plainSGR $ SetColor Background Dull  Green
 660   onYellow    = plainSGR $ SetColor Background Dull  Yellow
 661   onBlue      = plainSGR $ SetColor Background Dull  Blue
 662   onMagenta   = plainSGR $ SetColor Background Dull  Magenta
 663   onCyan      = plainSGR $ SetColor Background Dull  Cyan
 664   onWhite     = plainSGR $ SetColor Background Dull  White
 665   onBlacker   = plainSGR $ SetColor Background Vivid Black
 666   onRedder    = plainSGR $ SetColor Background Vivid Red
 667   onGreener   = plainSGR $ SetColor Background Vivid Green
 668   onYellower  = plainSGR $ SetColor Background Vivid Yellow
 669   onBluer     = plainSGR $ SetColor Background Vivid Blue
 670   onMagentaer = plainSGR $ SetColor Background Vivid Magenta
 671   onCyaner    = plainSGR $ SetColor Background Vivid Cyan
 672   onWhiter    = plainSGR $ SetColor Background Vivid White
 673 instance Outputable o => Decorable (Plain o) where
 674   bold      = plainSGR $ SetConsoleIntensity BoldIntensity
 675   underline = plainSGR $ SetUnderlining SingleUnderline
 676   italic    = plainSGR $ SetItalicized True
 677
 678 plainSGR :: Outputable o => SGR -> Plain o a -> Plain o a
 679 plainSGR newSGR p = before .> middle <. after
 680   where
 681   before = Plain $ \() inh st k ->
 682     let o = fromString $ setSGRCode [newSGR] in
 683     if plainInh_justify inh
 684     then k (id, st
 685      { plainState_buffer =
 686       PlainChunk_Ignored o :
 687       plainState_buffer st
 688      })
 689     else k ((o <>), st)
 690   middle = Plain $ \a inh ->
 691     unPlain p a inh{plainInh_sgr=newSGR:plainInh_sgr inh}
 692   after = Plain $ \() inh st k ->
 693     let o = fromString $ setSGRCode $ Reset : List.reverse (plainInh_sgr inh) in
 694     if plainInh_justify inh
 695     then k (id, st
 696      { plainState_buffer =
 697       PlainChunk_Ignored o :
 698       plainState_buffer st
 699      })
 700     else k ((o <>), st)