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