src/Symantic/Plaintext/Writer.hs

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