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