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 runPlain :: Monoid o => Plain o a -> a -> o
  54 runPlain x a =
  55   unPlain x a
  56    defPlainInh
  57    defPlainState
  58    {-k-}(\(px,_sx) fits _overflow ->
  59     -- NOTE: if px fits, then appending mempty fits
  60     fits (px mempty) )
  61    {-fits-}id
  62    {-overflow-}id
  63
  64 instance Semigroup o => ProductFunctor (Plain o) where
  65   x <.> y = Plain $ \(a,b) inh st k ->
  66     unPlain x a inh st $ \(px,sx) ->
  67       unPlain y b inh sx $ \(py,sy) ->
  68         k (px.py, sy)
  69   x .> y = Plain $ \b inh st k ->
  70     unPlain x () inh st $ \(px,sx) ->
  71       unPlain y b inh sx $ \(py,sy) ->
  72         k (px.py, sy)
  73   x <. y = Plain $ \a inh st k ->
  74     unPlain x a inh st $ \(px,sx) ->
  75       unPlain y () inh sx $ \(py,sy) ->
  76         k (px.py, sy)
  77 instance Emptyable (Plain o) where
  78   empty = Plain $ \_a _inh st k -> k (id,st)
  79 instance Outputable o => Repeatable (Plain o) where
  80   many0 item = Plain $ \as ->
  81     unPlain (concat ((`void` item) <$> as)) ()
  82   many1 item = Plain $ \case
  83     [] -> error "many1"
  84     as -> unPlain (concat ((`void` item) <$> as)) ()
  85
  86 -- String
  87 instance (Convertible String o, Outputable o) => IsString (Plain o ()) where
  88   fromString = convert
  89 instance (Convertible String o, Outputable o) => Convertible String (Plain o ()) where
  90   convert =
  91     concat .
  92     List.intersperse newline .
  93     (
  94       concat .
  95       List.intersperse breakspace .
  96       (wordPlain <$>) .
  97       words <$>
  98     ) . lines
  99 instance (Convertible T.Text o, Convertible Char o, Outputable o) => Convertible T.Text (Plain o ()) where
 100   convert =
 101     concat .
 102     List.intersperse newline .
 103     (
 104       concat .
 105       List.intersperse breakspace .
 106       (wordPlain <$>) .
 107       words <$>
 108     ) . lines
 109 instance (Convertible TL.Text o, Convertible Char o, Outputable o) => Convertible TL.Text (Plain o ()) where
 110   convert =
 111     concat .
 112     List.intersperse newline .
 113     (
 114       concat .
 115       List.intersperse breakspace .
 116       (wordPlain <$>) .
 117       words <$>
 118     ) . lines
 119
 120 instance (Convertible String o, Outputable o) => Inferable Int (Plain o) where
 121   infer = showWordPlain
 122 instance (Convertible String o, Outputable o) => Inferable Natural (Plain o) where
 123   infer = showWordPlain
 124 instance (Convertible String o, Outputable o) => Inferable (Word String) (Plain o) where
 125   infer = Plain $ ($ ()) . unPlain . wordPlain
 126 instance (Convertible String o, Outputable o) => Inferable String (Plain o) where
 127   infer = Plain $ ($ ()) . unPlain . fromString
 128 instance (Convertible T.Text o, Convertible Char o, Outputable o) => Inferable T.Text (Plain o) where
 129   infer = Plain $ ($ ()) . unPlain . convert
 130 instance (Convertible TL.Text o, Convertible Char o, Outputable o) => Inferable TL.Text (Plain o) where
 131   infer = Plain $ ($ ()) . unPlain . convert
 132 instance Outputable o => Inferable Char (Plain o) where
 133   infer = Plain $ \case
 134     '\n' -> unPlain newline ()
 135     ' ' -> unPlain breakspace ()
 136     c -> unPlain (wordPlain (Word c)) ()
 137 instance Outputable o => Inferable (Word Char) (Plain o) where
 138   infer = Plain $ \c -> unPlain (wordPlain c) ()
 139 showWordPlain ::
 140   Show a =>
 141   Convertible String o =>
 142   Outputable o =>
 143   Inferable a (Plain o) => Plain o a
 144 showWordPlain = Plain $
 145   ($ ()) . unPlain . wordPlain .
 146   Word . show
 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   go 0  bmr = List.replicate (fromIntegral bmr) q    -- when min (b-r) r == b-r
 597   go rr 0   = List.replicate (fromIntegral rr) (q+1) -- when min (b-r) r == r
 598   go rr bmr = q:(q+1) : go (rr`minusNatural`1) (bmr`minusNatural`1)
 599
 600 padLinePlainChunkInits ::
 601  Outputable o =>
 602  Width -> (Natural, Natural, [PlainChunk o]) -> Line o
 603 padLinePlainChunkInits maxWidth (lineWidth,wordCount,line) = Line $
 604   if maxWidth <= lineWidth
 605     -- The gathered line reached or overreached the maxWidth,
 606     -- hence no padding id needed.
 607   || wordCount <= 1
 608     -- The case maxWidth <= lineWidth && wordCount == 1
 609     -- can happen if first word's length is < maxWidth
 610     -- but second word's len is >= maxWidth.
 611   then joinLinePlainChunk line
 612   else
 613     -- Share the missing spaces as evenly as possible
 614     -- between the words of the line.
 615     padLinePlainChunk line $ justifyPadding (maxWidth-lineWidth) (wordCount-1)
 616
 617 -- | Interleave 'PlainChunk's with 'Width's from 'justifyPadding'.
 618 padLinePlainChunk :: Outputable o => [PlainChunk o] -> [Width] -> o
 619 padLinePlainChunk = go
 620   where
 621   go (w:ws) lls@(l:ls) =
 622     case w of
 623       PlainChunk_Spaces _s -> repeatedChar (fromIntegral (l+1)) ' ' <> go ws ls
 624       _ -> runPlainChunk w <> go ws lls
 625   go (w:ws) [] = runPlainChunk w <> go ws []
 626   go [] _ls = mempty
 627
 628
 629 sgrPlain :: Outputable o => [SGR] -> Plain o ()
 630 sgrPlain sgr = Plain $ \() inh st k ->
 631   if plainInh_justify inh
 632   then k (id, st {plainState_buffer =
 633     PlainChunk_Ignored (fromString (setSGRCode sgr)) :
 634     plainState_buffer st
 635   })
 636   else k ((fromString (setSGRCode sgr) <>), st)
 637
 638 instance Outputable o => Colorable16 (Plain o) where
 639   reverse     = plainSGR $ SetSwapForegroundBackground True
 640   black       = plainSGR $ SetColor Foreground Dull  Black
 641   red         = plainSGR $ SetColor Foreground Dull  Red
 642   green       = plainSGR $ SetColor Foreground Dull  Green
 643   yellow      = plainSGR $ SetColor Foreground Dull  Yellow
 644   blue        = plainSGR $ SetColor Foreground Dull  Blue
 645   magenta     = plainSGR $ SetColor Foreground Dull  Magenta
 646   cyan        = plainSGR $ SetColor Foreground Dull  Cyan
 647   white       = plainSGR $ SetColor Foreground Dull  White
 648   blacker     = plainSGR $ SetColor Foreground Vivid Black
 649   redder      = plainSGR $ SetColor Foreground Vivid Red
 650   greener     = plainSGR $ SetColor Foreground Vivid Green
 651   yellower    = plainSGR $ SetColor Foreground Vivid Yellow
 652   bluer       = plainSGR $ SetColor Foreground Vivid Blue
 653   magentaer   = plainSGR $ SetColor Foreground Vivid Magenta
 654   cyaner      = plainSGR $ SetColor Foreground Vivid Cyan
 655   whiter      = plainSGR $ SetColor Foreground Vivid White
 656   onBlack     = plainSGR $ SetColor Background Dull  Black
 657   onRed       = plainSGR $ SetColor Background Dull  Red
 658   onGreen     = plainSGR $ SetColor Background Dull  Green
 659   onYellow    = plainSGR $ SetColor Background Dull  Yellow
 660   onBlue      = plainSGR $ SetColor Background Dull  Blue
 661   onMagenta   = plainSGR $ SetColor Background Dull  Magenta
 662   onCyan      = plainSGR $ SetColor Background Dull  Cyan
 663   onWhite     = plainSGR $ SetColor Background Dull  White
 664   onBlacker   = plainSGR $ SetColor Background Vivid Black
 665   onRedder    = plainSGR $ SetColor Background Vivid Red
 666   onGreener   = plainSGR $ SetColor Background Vivid Green
 667   onYellower  = plainSGR $ SetColor Background Vivid Yellow
 668   onBluer     = plainSGR $ SetColor Background Vivid Blue
 669   onMagentaer = plainSGR $ SetColor Background Vivid Magenta
 670   onCyaner    = plainSGR $ SetColor Background Vivid Cyan
 671   onWhiter    = plainSGR $ SetColor Background Vivid White
 672 instance Outputable o => Decorable (Plain o) where
 673   bold      = plainSGR $ SetConsoleIntensity BoldIntensity
 674   underline = plainSGR $ SetUnderlining SingleUnderline
 675   italic    = plainSGR $ SetItalicized True
 676
 677 plainSGR :: Outputable o => SGR -> Plain o a -> Plain o a
 678 plainSGR newSGR p = before .> middle <. after
 679   where
 680   before = Plain $ \() inh st k ->
 681     let o = fromString $ setSGRCode [newSGR] in
 682     if plainInh_justify inh
 683     then k (id, st
 684      { plainState_buffer =
 685       PlainChunk_Ignored o :
 686       plainState_buffer st
 687      })
 688     else k ((o <>), st)
 689   middle = Plain $ \a inh ->
 690     unPlain p a inh{plainInh_sgr=newSGR:plainInh_sgr inh}
 691   after = Plain $ \() inh st k ->
 692     let o = fromString $ setSGRCode $ Reset : List.reverse (plainInh_sgr inh) in
 693     if plainInh_justify inh
 694     then k (id, st
 695      { plainState_buffer =
 696       PlainChunk_Ignored o :
 697       plainState_buffer st
 698      })
 699     else k ((o <>), st)