lib/Hcompta/Lib/Leijen.hs

   1 {-# LANGUAGE CPP #-}
   2 -----------------------------------------------------------------------------
   3 -- |
   4 -- Module      :  Hcompta.Lib.Leijen
   5 -- Copyright   :  Julien Moutinho <julm+hcompta@autogeree.net> (c) 2015,
   6 --                Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com> (c) 2010,
   7 --                Daan Leijen (c) 2000, http://www.cs.uu.nl/~daan
   8 -- License     :  BSD-style
   9 --
  10 -- Stability   :  provisional
  11 -- Portability :  portable
  12 --
  13 -- This module is a merge between /wl-pprint-text/ and /ansi-wl-pprint/ packages
  14 -- to use 'Text' values rather than 'String's and ANSI formatting.
  15 --
  16 -- Pretty print module based on Philip Wadler's \"prettier printer\"
  17 --
  18 -- @
  19 --      \"A prettier printer\"
  20 --      Draft paper, April 1997, revised March 1998.
  21 --      <http://cm.bell-labs.com/cm/cs/who/wadler/papers/prettier/prettier.ps>
  22 -- @
  23 --
  24 -- PPrint is an implementation of the pretty printing combinators
  25 -- described by Philip Wadler (1997). In their bare essence, the
  26 -- combinators of Wadler are not expressive enough to describe some
  27 -- commonly occurring layouts. The PPrint library adds new primitives
  28 -- to describe these layouts and works well in practice.
  29 --
  30 -- The library is based on a single way to concatenate documents,
  31 -- which is associative and has both a left and right unit.  This
  32 -- simple design leads to an efficient and short implementation. The
  33 -- simplicity is reflected in the predictable behaviour of the
  34 -- combinators which make them easy to use in practice.
  35 --
  36 -- A thorough description of the primitive combinators and their
  37 -- implementation can be found in Philip Wadler's paper
  38 -- (1997). Additions and the main differences with his original paper
  39 -- are:
  40 --
  41 -- * The nil document is called empty.
  42 --
  43 -- * The above combinator is called '<$>'. The operator '</>' is used
  44 --   for soft line breaks.
  45 --
  46 -- * There are three new primitives: 'align', 'fill' and
  47 --   'fillBreak'. These are very useful in practice.
  48 --
  49 -- * Lots of other useful combinators, like 'fillSep' and 'list'.
  50 --
  51 -- * There are two renderers, 'renderPretty' for pretty printing and
  52 --   'renderCompact' for compact output. The pretty printing algorithm
  53 --   also uses a ribbon-width now for even prettier output.
  54 --
  55 -- * There are two displayers, 'displayT' for 'Text' values and 'displayIO'
  56 --   for file based output.
  57 --
  58 -- * There is a 'Pretty' class.
  59 --
  60 -- * The implementation uses optimised representations and strictness
  61 --   annotations.
  62 --
  63 -- Ways that this library differs from /wl-pprint/ (apart from using
  64 -- 'Text' rather than 'String'):
  65 --
  66 -- * Smarter treatment of 'empty' sub-documents (partially copied over
  67 --   from the /pretty/ library).
  68 -----------------------------------------------------------
  69 module Hcompta.Lib.Leijen (
  70    -- * Documents
  71    Doc,
  72
  73    -- * Basic combinators
  74    empty, char, text, strict_text, (<>), nest, line, linebreak, group, softline,
  75    softbreak, spacebreak, renderSmart,
  76    -- flatAlt
  77
  78    -- * Tests
  79    is_empty,
  80    if_color,
  81
  82    -- * Alignment
  83    --
  84    -- | The combinators in this section can not be described by Wadler's
  85    --   original combinators. They align their output relative to the
  86    --   current output position - in contrast to @nest@ which always
  87    --   aligns to the current nesting level. This deprives these
  88    --   combinators from being \`optimal\'. In practice however they
  89    --   prove to be very useful. The combinators in this section should
  90    --   be used with care, since they are more expensive than the other
  91    --   combinators. For example, @align@ shouldn't be used to pretty
  92    --   print all top-level declarations of a language, but using @hang@
  93    --   for let expressions is fine.
  94    align, hang, indent, encloseSep, list, tupled, semiBraces,
  95
  96    -- * Operators
  97    (<+>), (<++>), (<$>), (</>), (<$$>), (<//>),
  98
  99    -- * List combinators
 100    hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate, intercalate,
 101
 102    -- * Fillers
 103    fill, fillBreak,
 104
 105    -- * Bracketing combinators
 106    enclose, squotes, dquotes, parens, angles, braces, brackets,
 107
 108    -- * Character documents
 109    lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket,
 110    squote, dquote, semi, colon, comma, space, dot, backslash, equals,
 111
 112    -- * Colorisation combinators
 113    black, red, green, yellow, blue, magenta, cyan, white,
 114    dullblack, dullred, dullgreen, dullyellow, dullblue, dullmagenta, dullcyan, dullwhite,
 115    onblack, onred, ongreen, onyellow, onblue, onmagenta, oncyan, onwhite,
 116    ondullblack, ondullred, ondullgreen, ondullyellow, ondullblue, ondullmagenta, ondullcyan, ondullwhite,
 117
 118    -- * Emboldening combinators
 119    bold, debold,
 120
 121    -- * Underlining combinators
 122    underline, deunderline,
 123
 124    -- * Removing formatting
 125    plain,
 126
 127    -- * Primitive type documents
 128    string, int, integer, float, double, rational, bool,
 129
 130    -- * Position-based combinators
 131    column, nesting, width,
 132
 133    -- * Pretty class
 134    Pretty(..),
 135
 136    -- * Rendering
 137    SimpleDoc(..), renderPretty, renderCompact, renderOneLine,
 138    displayB, displayT, displayIO, putDoc, hPutDoc,
 139
 140    ) where
 141
 142 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 710
 143 import Prelude hiding ((<$>))
 144 #endif
 145
 146 import Data.String (IsString (..))
 147 import System.IO   (Handle, hPutChar, stdout)
 148 import System.Console.ANSI (Color(..), ColorIntensity(..), ConsoleLayer(..),
 149                             Underlining(..), ConsoleIntensity(..),
 150                             SGR(..), hSetSGR, setSGRCode)
 151
 152 import           Data.Int               (Int64)
 153 import           Data.Maybe             (catMaybes)
 154 import           Data.Monoid            (Monoid (..), (<>))
 155 import qualified Data.Foldable          (Foldable(..))
 156 import qualified Data.Text              (Text)
 157 import           Data.Text.Lazy         (Text)
 158 import qualified Data.Text.Lazy         as T
 159 import           Data.Text.Lazy.Builder (Builder)
 160 import qualified Data.Text.Lazy.Builder as B
 161 import qualified Data.Text.Lazy.IO      as T
 162
 163
 164 infixr 5 </>,<//>,<$>,<$$>
 165 infixr 6 <+>,<++>
 166
 167
 168 -----------------------------------------------------------
 169 -- list, tupled and semiBraces pretty print a list of
 170 -- documents either horizontally or vertically aligned.
 171 -----------------------------------------------------------
 172
 173
 174 -- | The document @(list xs)@ comma separates the documents @xs@ and
 175 --   encloses them in square brackets. The documents are rendered
 176 --   horizontally if that fits the page. Otherwise they are aligned
 177 --   vertically. All comma separators are put in front of the
 178 --   elements.
 179 list :: [Doc] -> Doc
 180 list = encloseSep lbracket rbracket comma
 181
 182 -- | The document @(tupled xs)@ comma separates the documents @xs@ and
 183 --   encloses them in parenthesis. The documents are rendered
 184 --   horizontally if that fits the page. Otherwise they are aligned
 185 --   vertically. All comma separators are put in front of the
 186 --   elements.
 187 tupled :: [Doc] -> Doc
 188 tupled = encloseSep lparen rparen comma
 189
 190 -- | The document @(semiBraces xs)@ separates the documents @xs@ with
 191 --   semi colons and encloses them in braces. The documents are
 192 --   rendered horizontally if that fits the page. Otherwise they are
 193 --   aligned vertically. All semi colons are put in front of the
 194 --   elements.
 195 semiBraces :: [Doc] -> Doc
 196 semiBraces = encloseSep lbrace rbrace semi
 197
 198 -- | The document @(encloseSep l r sep xs)@ concatenates the documents
 199 --   @xs@ separated by @sep@ and encloses the resulting document by
 200 --   @l@ and @r@. The documents are rendered horizontally if that fits
 201 --   the page. Otherwise they are aligned vertically. All separators
 202 --   are put in front of the elements. For example, the combinator
 203 --   'list' can be defined with @encloseSep@:
 204 --
 205 --   > list xs = encloseSep lbracket rbracket comma xs
 206 --   > test = text "list" <+> (list (map int [10,200,3000]))
 207 --
 208 --   Which is laid out with a page width of 20 as:
 209 --
 210 --   @
 211 --   list [10,200,3000]
 212 --   @
 213 --
 214 --   But when the page width is 15, it is laid out as:
 215 --
 216 --   @
 217 --   list [10
 218 --        ,200
 219 --        ,3000]
 220 --   @
 221 encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc
 222 encloseSep left right sp ds
 223   = case ds of
 224       []  -> left <> right
 225       [d] -> left <> d <> right
 226       _   -> align (cat (zipWith (<>) (left : repeat sp) ds) <> right)
 227
 228 -----------------------------------------------------------
 229 -- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn]
 230 -----------------------------------------------------------
 231
 232
 233 -- | @(punctuate p xs)@ concatenates all documents in @xs@ with
 234 --   document @p@ except for the last document.
 235 --
 236 --   > someText = map text ["words","in","a","tuple"]
 237 --   > test = parens (align (cat (punctuate comma someText)))
 238 --
 239 --   This is laid out on a page width of 20 as:
 240 --
 241 --   @
 242 --   (words,in,a,tuple)
 243 --   @
 244 --
 245 --   But when the page width is 15, it is laid out as:
 246 --
 247 --   @
 248 --   (words,
 249 --    in,
 250 --    a,
 251 --    tuple)
 252 --   @
 253 --
 254 --   (If you want put the commas in front of their elements instead of
 255 --   at the end, you should use 'tupled' or, in general, 'encloseSep'.)
 256 punctuate :: Doc -> [Doc] -> [Doc]
 257 punctuate _ [] = []
 258 punctuate _ [d] = [d]
 259 punctuate p (d:ds) = (d <> p) : punctuate p ds
 260
 261
 262 -----------------------------------------------------------
 263 -- high-level combinators
 264 -----------------------------------------------------------
 265
 266
 267 -- | The document @(sep xs)@ concatenates all documents @xs@ either
 268 --   horizontally with @(\<+\>)@, if it fits the page, or vertically
 269 --   with @(\<$\>)@.
 270 --
 271 --   > sep xs = group (vsep xs)
 272 sep :: [Doc] -> Doc
 273 sep = group . vsep
 274
 275 -- | The document @(fillSep xs)@ concatenates documents @xs@
 276 --   horizontally with @(\<+\>)@ as long as its fits the page, then
 277 --   inserts a @line@ and continues doing that for all documents in
 278 --   @xs@.
 279 --
 280 --   > fillSep xs = foldr (</>) empty xs
 281 fillSep :: [Doc] -> Doc
 282 fillSep = fold (</>)
 283
 284 -- | The document @(hsep xs)@ concatenates all documents @xs@
 285 --   horizontally with @(\<+\>)@.
 286 hsep :: [Doc] -> Doc
 287 hsep = fold (<+>)
 288
 289 -- | The document @(vsep xs)@ concatenates all documents @xs@
 290 --   vertically with @(\<$\>)@. If a 'group' undoes the line breaks
 291 --   inserted by @vsep@, all documents are separated with a space.
 292 --
 293 --   > someText = map text (words ("text to lay out"))
 294 --   >
 295 --   > test = text "some" <+> vsep someText
 296 --
 297 --   This is laid out as:
 298 --
 299 --   @
 300 --   some text
 301 --   to
 302 --   lay
 303 --   out
 304 --   @
 305 --
 306 --   The 'align' combinator can be used to align the documents under
 307 --   their first element
 308 --
 309 --   > test = text "some" <+> align (vsep someText)
 310 --
 311 --   Which is printed as:
 312 --
 313 --   @
 314 --   some text
 315 --        to
 316 --        lay
 317 --        out
 318 --   @
 319 vsep :: [Doc] -> Doc
 320 vsep = fold (<$>)
 321
 322 -- | The document @(cat xs)@ concatenates all documents @xs@ either
 323 --   horizontally with @(\<\>)@, if it fits the page, or vertically
 324 --   with @(\<$$\>)@.
 325 --
 326 --   > cat xs = group (vcat xs)
 327 cat :: [Doc] -> Doc
 328 cat = group . vcat
 329
 330 -- | The document @(fillCat xs)@ concatenates documents @xs@
 331 --   horizontally with @(\<\>)@ as long as its fits the page, then
 332 --   inserts a @linebreak@ and continues doing that for all documents
 333 --   in @xs@.
 334 --
 335 --   > fillCat xs = foldr (<//>) empty xs
 336 fillCat :: [Doc] -> Doc
 337 fillCat = fold (<//>)
 338
 339 -- | The document @(hcat xs)@ concatenates all documents @xs@
 340 --   horizontally with @(\<\>)@.
 341 hcat :: [Doc] -> Doc
 342 hcat = fold (<>)
 343
 344 -- | The document @(vcat xs)@ concatenates all documents @xs@
 345 --   vertically with @(\<$$\>)@. If a 'group' undoes the line breaks
 346 --   inserted by @vcat@, all documents are directly concatenated.
 347 vcat :: [Doc] -> Doc
 348 vcat = fold (<$$>)
 349
 350 fold      :: (Doc -> Doc -> Doc) -> [Doc] -> Doc
 351 fold _ [] = empty
 352 fold f ds = foldr1 f ds
 353
 354 -- | The document @(x \<+\> y)@ concatenates document @x@ and @y@ with
 355 --   a 'space' in between.  (infixr 6)
 356 (<+>) :: Doc -> Doc -> Doc
 357 Empty <+> y     = y
 358 x     <+> Empty = x
 359 x     <+> y     = x <> space <> y
 360
 361 -- | The document @(x \<++\> y)@ concatenates document @x@ and @y@ with
 362 --   a 'spacebreak' in between.  (infixr 6)
 363 (<++>) :: Doc -> Doc -> Doc
 364 Empty <++> y     = y
 365 x     <++> Empty = x
 366 x     <++> y     = x <> spacebreak <> y
 367
 368
 369 -- | The document @(x \<\/\> y)@ concatenates document @x@ and @y@
 370 --   with a 'softline' in between. This effectively puts @x@ and @y@
 371 --   either next to each other (with a @space@ in between) or
 372 --   underneath each other. (infixr 5)
 373 (</>) :: Doc -> Doc -> Doc
 374 (</>) = splitWithBreak False
 375
 376 -- | The document @(x \<\/\/\> y)@ concatenates document @x@ and @y@
 377 --   with a 'softbreak' in between. This effectively puts @x@ and @y@
 378 --   either right next to each other or underneath each other. (infixr
 379 --   5)
 380 (<//>) :: Doc -> Doc -> Doc
 381 (<//>) = splitWithBreak True
 382
 383 splitWithBreak               :: Bool -> Doc -> Doc -> Doc
 384 splitWithBreak _ Empty b     = b
 385 splitWithBreak _ a     Empty = a
 386 splitWithBreak f a     b     = a <> group (Line f) <> b
 387
 388 -- | The document @(x \<$\> y)@ concatenates document @x@ and @y@ with
 389 --   a 'line' in between. (infixr 5)
 390 (<$>) :: Doc -> Doc -> Doc
 391 (<$>) = splitWithLine False
 392
 393 -- | The document @(x \<$$\> y)@ concatenates document @x@ and @y@
 394 --   with a 'linebreak' in between. (infixr 5)
 395 (<$$>) :: Doc -> Doc -> Doc
 396 (<$$>) = splitWithLine True
 397
 398 splitWithLine               :: Bool -> Doc -> Doc -> Doc
 399 splitWithLine _ Empty b     = b
 400 splitWithLine _ a     Empty = a
 401 splitWithLine f a     b     = a <> Line f <> b
 402
 403 -- | The document @softline@ behaves like 'space' if the resulting
 404 --   output fits the page, otherwise it behaves like 'line'.
 405 --
 406 --   > softline = group line
 407 softline :: Doc
 408 softline = group line
 409
 410 -- | The document @softbreak@ behaves like 'empty' if the resulting
 411 --   output fits the page, otherwise it behaves like 'line'.
 412 --
 413 --   > softbreak = group linebreak
 414 softbreak :: Doc
 415 softbreak = group linebreak
 416
 417 -- | The document @spacebreak@ behaves like 'space' when rendered normally
 418 -- but like 'empty' when using 'renderCompact' or 'renderOneLine'.
 419 spacebreak :: Doc
 420 spacebreak = Spaces 1
 421
 422 -- | Document @(squotes x)@ encloses document @x@ with single quotes
 423 --   \"'\".
 424 squotes :: Doc -> Doc
 425 squotes = enclose squote squote
 426
 427 -- | Document @(dquotes x)@ encloses document @x@ with double quotes
 428 --   '\"'.
 429 dquotes :: Doc -> Doc
 430 dquotes = enclose dquote dquote
 431
 432 -- | Document @(braces x)@ encloses document @x@ in braces, \"{\" and
 433 --   \"}\".
 434 braces :: Doc -> Doc
 435 braces = enclose lbrace rbrace
 436
 437 -- | Document @(parens x)@ encloses document @x@ in parenthesis, \"(\"
 438 --   and \")\".
 439 parens :: Doc -> Doc
 440 parens = enclose lparen rparen
 441
 442 -- | Document @(angles x)@ encloses document @x@ in angles, \"\<\" and
 443 --   \"\>\".
 444 angles :: Doc -> Doc
 445 angles = enclose langle rangle
 446
 447 -- | Document @(brackets x)@ encloses document @x@ in square brackets,
 448 --   \"[\" and \"]\".
 449 brackets :: Doc -> Doc
 450 brackets = enclose lbracket rbracket
 451
 452 -- | The document @(enclose l r x)@ encloses document @x@ between
 453 --   documents @l@ and @r@ using @(\<\>)@.
 454 --
 455 --   > enclose l r x = l <> x <> r
 456 enclose       :: Doc -> Doc -> Doc -> Doc
 457 enclose l r x = l <> x <> r
 458
 459 -- | The document @lparen@ contains a left parenthesis, \"(\".
 460 lparen :: Doc
 461 lparen = char '('
 462
 463 -- | The document @rparen@ contains a right parenthesis, \")\".
 464 rparen :: Doc
 465 rparen = char ')'
 466
 467 -- | The document @langle@ contains a left angle, \"\<\".
 468 langle :: Doc
 469 langle = char '<'
 470
 471 -- | The document @rangle@ contains a right angle, \">\".
 472 rangle :: Doc
 473 rangle = char '>'
 474
 475 -- | The document @lbrace@ contains a left brace, \"{\".
 476 lbrace :: Doc
 477 lbrace = char '{'
 478
 479 -- | The document @rbrace@ contains a right brace, \"}\".
 480 rbrace :: Doc
 481 rbrace = char '}'
 482
 483 -- | The document @lbracket@ contains a left square bracket, \"[\".
 484 lbracket :: Doc
 485 lbracket = char '['
 486
 487 -- | The document @rbracket@ contains a right square bracket, \"]\".
 488 rbracket :: Doc
 489 rbracket = char ']'
 490
 491 -- | The document @squote@ contains a single quote, \"'\".
 492 squote :: Doc
 493 squote = char '\''
 494
 495 -- | The document @dquote@ contains a double quote, '\"'.
 496 dquote :: Doc
 497 dquote = char '"'
 498
 499 -- | The document @semi@ contains a semi colon, \";\".
 500 semi :: Doc
 501 semi = char ';'
 502
 503 -- | The document @colon@ contains a colon, \":\".
 504 colon :: Doc
 505 colon = char ':'
 506
 507 -- | The document @comma@ contains a comma, \",\".
 508 comma :: Doc
 509 comma = char ','
 510
 511 -- | The document @space@ contains a single space, \" \".
 512 --
 513 --   > x <+> y = x <> space <> y
 514 space :: Doc
 515 space = char ' '
 516
 517 -- | The document @dot@ contains a single dot, \".\".
 518 dot :: Doc
 519 dot = char '.'
 520
 521 -- | The document @backslash@ contains a back slash, \"\\\".
 522 backslash :: Doc
 523 backslash = char '\\'
 524
 525 -- | The document @equals@ contains an equal sign, \"=\".
 526 equals :: Doc
 527 equals = char '='
 528
 529 -----------------------------------------------------------
 530 -- Combinators for prelude types
 531 -----------------------------------------------------------
 532
 533 -- string is like "text" but replaces '\n' by "line"
 534
 535 -- | The document @(string s)@ concatenates all characters in @s@
 536 --   using @line@ for newline characters and @char@ for all other
 537 --   characters. It is used instead of 'text' whenever the text
 538 --   contains newline characters.
 539 string :: Text -> Doc
 540 string str = case T.uncons str of
 541                Nothing          -> empty
 542                Just ('\n',str') -> line <> string str'
 543                _                -> case (T.span (/='\n') str) of
 544                                      (xs,ys) -> text xs <> string ys
 545
 546 -- | The document @(bool b)@ shows the literal boolean @b@ using
 547 --   'text'.
 548 bool   :: Bool -> Doc
 549 bool b = text' b
 550
 551 -- | The document @(int i)@ shows the literal integer @i@ using
 552 --   'text'.
 553 int   :: Int -> Doc
 554 int i = text' i
 555
 556 -- | The document @(integer i)@ shows the literal integer @i@ using
 557 --   'text'.
 558 integer   :: Integer -> Doc
 559 integer i = text' i
 560
 561 -- | The document @(float f)@ shows the literal float @f@ using
 562 --   'text'.
 563 float   :: Float -> Doc
 564 float f = text' f
 565
 566 -- | The document @(double d)@ shows the literal double @d@ using
 567 --   'text'.
 568 double   :: Double -> Doc
 569 double d = text' d
 570
 571 -- | The document @(rational r)@ shows the literal rational @r@ using
 572 --   'text'.
 573 rational   :: Rational -> Doc
 574 rational r = text' r
 575
 576 text' :: (Show a) => a -> Doc
 577 text' = text . T.pack . show
 578
 579 -----------------------------------------------------------
 580 -- overloading "pretty"
 581 -----------------------------------------------------------
 582
 583 -- | The member @prettyList@ is only used to define the @instance
 584 --   Pretty a => Pretty [a]@. In normal circumstances only the
 585 --   @pretty@ function is used.
 586 class Pretty a where
 587   pretty :: a -> Doc
 588
 589   prettyList :: [a] -> Doc
 590   prettyList = list . map pretty
 591
 592 instance Pretty a => Pretty [a] where
 593   pretty = prettyList
 594
 595 instance Pretty Doc where
 596   pretty = id
 597
 598 instance Pretty Text where
 599   pretty = string
 600
 601 instance Pretty () where
 602   pretty () = text' ()
 603
 604 instance Pretty Bool where
 605   pretty b = bool b
 606
 607 instance Pretty Char where
 608   pretty c = char c
 609
 610   prettyList s = string $ T.pack s
 611
 612 instance Pretty Int where
 613   pretty i = int i
 614
 615 instance Pretty Integer where
 616   pretty i = integer i
 617
 618 instance Pretty Float where
 619   pretty f = float f
 620
 621 instance Pretty Double where
 622   pretty d = double d
 623
 624 --instance Pretty Rational where
 625 --  pretty r = rational r
 626
 627 instance (Pretty a,Pretty b) => Pretty (a,b) where
 628   pretty (x,y) = tupled [pretty x, pretty y]
 629
 630 instance (Pretty a,Pretty b,Pretty c) => Pretty (a,b,c) where
 631   pretty (x,y,z)= tupled [pretty x, pretty y, pretty z]
 632
 633 instance Pretty a => Pretty (Maybe a) where
 634   pretty Nothing = empty
 635
 636   pretty (Just x) = pretty x
 637
 638 -----------------------------------------------------------
 639 -- semi primitive: fill and fillBreak
 640 -----------------------------------------------------------
 641
 642 -- | The document @(fillBreak i x)@ first renders document @x@. It
 643 --   then appends @space@s until the width is equal to @i@. If the
 644 --   width of @x@ is already larger than @i@, the nesting level is
 645 --   increased by @i@ and a @line@ is appended. When we redefine
 646 --   @ptype@ in the previous example to use @fillBreak@, we get a
 647 --   useful variation of the previous output:
 648 --
 649 --   > ptype (name,tp)
 650 --   > = fillBreak 6 (text name) <+> text "::" <+> text tp
 651 --
 652 --   The output will now be:
 653 --
 654 --   @
 655 --   let empty  :: Doc
 656 --       nest   :: Int -> Doc -> Doc
 657 --       linebreak
 658 --              :: Doc
 659 --   @
 660 fillBreak     :: Int -> Doc -> Doc
 661 fillBreak f x = width x (\w ->
 662                           if (w > f)
 663                             then nest f linebreak
 664                             else spaced (f - w)
 665                         )
 666
 667
 668 -- | The document @(fill i x)@ renders document @x@. It then appends
 669 --   @space@s until the width is equal to @i@. If the width of @x@ is
 670 --   already larger, nothing is appended. This combinator is quite
 671 --   useful in practice to output a list of bindings. The following
 672 --   example demonstrates this.
 673 --
 674 --   > types = [("empty","Doc")
 675 --   >          ,("nest","Int -> Doc -> Doc")
 676 --   >          ,("linebreak","Doc")]
 677 --   >
 678 --   > ptype (name,tp)
 679 --   > = fill 6 (text name) <+> text "::" <+> text tp
 680 --   >
 681 --   > test = text "let" <+> align (vcat (map ptype types))
 682 --
 683 --   Which is laid out as:
 684 --
 685 --   @
 686 --   let empty  :: Doc
 687 --       nest   :: Int -> Doc -> Doc
 688 --       linebreak :: Doc
 689 --   @
 690 fill     :: Int -> Doc -> Doc
 691 fill f d = width d (\w ->
 692                      if (w >= f)
 693                        then empty
 694                        else spaced (f - w)
 695                    )
 696
 697
 698 width     :: Doc -> (Int -> Doc) -> Doc
 699 width d f = column (\k1 -> d <> column (\k2 -> f (k2 - k1)))
 700
 701 -----------------------------------------------------------
 702 -- semi primitive: Alignment and indentation
 703 -----------------------------------------------------------
 704
 705 -- | The document @(indent i x)@ indents document @x@ with @i@ spaces.
 706 --
 707 --   > test = indent 4 (fillSep (map text
 708 --   >         (words "the indent combinator indents these words !")))
 709 --
 710 --   Which lays out with a page width of 20 as:
 711 --
 712 --   @
 713 --       the indent
 714 --       combinator
 715 --       indents these
 716 --       words !
 717 --   @
 718 indent         :: Int -> Doc -> Doc
 719 indent _ Empty = Empty
 720 indent i d     = hang i (spaced i <> d)
 721
 722 -- | The hang combinator implements hanging indentation. The document
 723 --   @(hang i x)@ renders document @x@ with a nesting level set to the
 724 --   current column plus @i@. The following example uses hanging
 725 --   indentation for some text:
 726 --
 727 --   > test = hang 4 (fillSep (map text
 728 --   >         (words "the hang combinator indents these words !")))
 729 --
 730 --   Which lays out on a page with a width of 20 characters as:
 731 --
 732 --   @
 733 --   the hang combinator
 734 --       indents these
 735 --       words !
 736 --   @
 737 --
 738 --   The @hang@ combinator is implemented as:
 739 --
 740 --   > hang i x = align (nest i x)
 741 hang     :: Int -> Doc -> Doc
 742 hang i d = align (nest i d)
 743
 744 -- | The document @(align x)@ renders document @x@ with the nesting
 745 --   level set to the current column. It is used for example to
 746 --   implement 'hang'.
 747 --
 748 --   As an example, we will put a document right above another one,
 749 --   regardless of the current nesting level:
 750 --
 751 --   > x $$ y = align (x <$> y)
 752 --
 753 --   > test = text "hi" <+> (text "nice" $$ text "world")
 754 --
 755 --   which will be laid out as:
 756 --
 757 --   @
 758 --   hi nice
 759 --      world
 760 --   @
 761 align   :: Doc -> Doc
 762 align d = column (\k ->
 763                    nesting (\i -> nest (k - i) d))   --nesting might be negative :-)
 764
 765 -----------------------------------------------------------
 766 -- Primitives
 767 -----------------------------------------------------------
 768
 769 -- | The abstract data type @Doc@ represents pretty documents.
 770 --
 771 --   @Doc@ is an instance of the 'Show' class. @(show doc)@ pretty
 772 --   prints document @doc@ with a page width of 100 characters and a
 773 --   ribbon width of 40 characters.
 774 --
 775 --   > show (text "hello" <$> text "world")
 776 --
 777 --   Which would return the string \"hello\\nworld\", i.e.
 778 --
 779 --   @
 780 --   hello
 781 --   world
 782 --   @
 783 data Doc = Empty
 784          | Char Char             -- invariant: char is not '\n'
 785          | Text !Int64 Builder   -- invariant: text doesn't contain '\n'
 786          | Line !Bool            -- True <=> when undone by group, do not insert a space
 787          -- | FlatAlt Doc Doc       -- Render the first doc, but when
 788                                     -- flattened, render the second.
 789          | Cat Doc Doc
 790          | Nest !Int64 Doc
 791          | Union Doc Doc         -- invariant: first lines of first doc longer than the first lines of the second doc
 792          | Column  (Int64 -> Doc)
 793          | Nesting (Int64 -> Doc)
 794          | Spaces !Int64
 795          | Color ConsoleLayer ColorIntensity -- Introduces coloring /around/ the embedded document
 796                  Color Doc
 797          | IfColor Doc Doc
 798          | Intensify ConsoleIntensity Doc
 799          | Italicize Bool Doc
 800          | Underline Underlining Doc
 801          | RestoreFormat (Maybe (ColorIntensity, Color))  -- Only used during the rendered phase, to signal a SGR should be issued to restore the terminal formatting.
 802                          (Maybe (ColorIntensity, Color))  -- These are the colors to revert the current forecolor/backcolor to (i.e. those from before the start of the Color block).
 803                          (Maybe ConsoleIntensity)         -- Intensity to revert to.
 804                          (Maybe Bool)                     -- Italicization to revert to.
 805                          (Maybe Underlining)              -- Underlining to revert to.
 806
 807 instance IsString Doc where
 808   fromString = string . T.pack
 809
 810 -- | In particular, note that the document @(x '<>' y)@ concatenates
 811 --   document @x@ and document @y@. It is an associative operation
 812 --   having 'empty' as a left and right unit.  (infixr 6)
 813 instance Monoid Doc where
 814     mempty  = empty
 815     mappend = beside
 816
 817 -- | The data type @SimpleDoc@ represents rendered documents and is
 818 --   used by the display functions.
 819 --
 820 --   The @Int@ in @SText@ contains the length of the string. The @Int@
 821 --   in @SLine@ contains the indentation for that line. The library
 822 --   provides two default display functions 'displayS' and
 823 --   'displayIO'. You can provide your own display function by writing
 824 --   a function from a @SimpleDoc@ to your own output format.
 825 data SimpleDoc = SEmpty
 826                | SChar Char SimpleDoc
 827                | SText !Int64 Builder SimpleDoc
 828                | SLine !Int64 SimpleDoc
 829                | SSGR [SGR] SimpleDoc
 830
 831 -- | The empty document is, indeed, empty. Although @empty@ has no
 832 --   content, it does have a \'height\' of 1 and behaves exactly like
 833 --   @(text \"\")@ (and is therefore not a unit of @\<$\>@).
 834 empty :: Doc
 835 empty = Empty
 836
 837 is_empty :: Doc -> Bool
 838 is_empty doc = case doc of
 839          Empty -> True
 840          _     -> False
 841
 842 if_color :: Doc -> Doc -> Doc
 843 if_color = IfColor
 844
 845 -- | The document @(char c)@ contains the literal character @c@. The
 846 --   character shouldn't be a newline (@'\n'@), the function 'line'
 847 --   should be used for line breaks.
 848 char      :: Char -> Doc
 849 char '\n' = line
 850 char  c   = Char c
 851
 852 -- | The document @(text s)@ contains the literal string @s@. The
 853 --   string shouldn't contain any newline (@'\n'@) characters. If the
 854 --   string contains newline characters, the function 'string' should
 855 --   be used.
 856 text :: Text -> Doc
 857 text s
 858   | T.null s  = Empty
 859   | otherwise = Text (T.length s) (B.fromLazyText s)
 860
 861 -- | The @line@ document advances to the next line and indents to the
 862 --   current nesting level. Document @line@ behaves like @(text \"
 863 --   \")@ if the line break is undone by 'group' or if rendered with
 864 --   'renderOneLine'.
 865 line :: Doc
 866 line = Line False
 867 --line            = FlatAlt Line space
 868
 869 -- | The @linebreak@ document advances to the next line and indents to
 870 --   the current nesting level. Document @linebreak@ behaves like
 871 --   'empty' if the line break is undone by 'group'.
 872 linebreak :: Doc
 873 linebreak = Line True
 874 --linebreak       = FlatAlt Line empty
 875
 876 beside             :: Doc -> Doc -> Doc
 877 beside Empty r     = r
 878 beside l     Empty = l
 879 beside l     r     = Cat l r
 880
 881 -- | The document @(nest i x)@ renders document @x@ with the current
 882 --   indentation level increased by @i@ (See also 'hang', 'align' and
 883 --   'indent').
 884 --
 885 --   > nest 2 (text "hello" <$> text "world") <$> text "!"
 886 --
 887 --   outputs as:
 888 --
 889 --   @
 890 --   hello
 891 --     world
 892 --   !
 893 --   @
 894 nest         :: Int -> Doc -> Doc
 895 nest _ Empty = Empty
 896 nest i x     = Nest (fromIntegral i) x
 897
 898 -- | Specifies how to create the document based upon which column it is in.
 899 column   :: (Int -> Doc) -> Doc
 900 column f = Column (f . fromIntegral)
 901
 902 -- | Specifies how to nest the document based upon which column it is
 903 --   being nested in.
 904 nesting   :: (Int -> Doc) -> Doc
 905 nesting f = Nesting (f . fromIntegral)
 906
 907 -- | The @group@ combinator is used to specify alternative
 908 --   layouts. The document @(group x)@ undoes all line breaks in
 909 --   document @x@. The resulting line is added to the current line if
 910 --   that fits the page. Otherwise, the document @x@ is rendered
 911 --   without any changes.
 912 group   :: Doc -> Doc
 913 group x = Union (flatten x) x
 914
 915 flatten              :: Doc -> Doc
 916 flatten (Cat x y)   = Cat (flatten x) (flatten y)
 917 flatten (Nest i x)  = Nest i (flatten x)
 918 flatten (Line brk)  = if brk then Empty else Text 1 (B.singleton ' ')
 919 flatten (Union x _) = flatten x
 920 flatten (Column f)  = Column (flatten . f)
 921 flatten (Nesting f) = Nesting (flatten . f)
 922 flatten (Color l i c x)  = Color l i c (flatten x)
 923 flatten (IfColor t f)  = IfColor (flatten t) (flatten f)
 924 flatten (Intensify i x)  = Intensify i (flatten x)
 925 flatten (Italicize b x)  = Italicize b (flatten x)
 926 flatten (Underline u x)  = Underline u (flatten x)
 927 -- flatten (FlatAlt x y)    = y
 928 flatten other       = other                     --Empty,Char,Text,RestoreFormat
 929
 930
 931 -----------------------------------------------------------
 932 -- Colors
 933 -----------------------------------------------------------
 934
 935 -- | Displays a document with the black forecolor
 936 black :: Doc -> Doc
 937 -- | Displays a document with the red forecolor
 938 red :: Doc -> Doc
 939 -- | Displays a document with the green forecolor
 940 green :: Doc -> Doc
 941 -- | Displays a document with the yellow forecolor
 942 yellow :: Doc -> Doc
 943 -- | Displays a document with the blue forecolor
 944 blue :: Doc -> Doc
 945 -- | Displays a document with the magenta forecolor
 946 magenta :: Doc -> Doc
 947 -- | Displays a document with the cyan forecolor
 948 cyan :: Doc -> Doc
 949 -- | Displays a document with the white forecolor
 950 white :: Doc -> Doc
 951 -- | Displays a document with the dull black forecolor
 952 dullblack :: Doc -> Doc
 953 -- | Displays a document with the dull red forecolor
 954 dullred :: Doc -> Doc
 955 -- | Displays a document with the dull green forecolor
 956 dullgreen :: Doc -> Doc
 957 -- | Displays a document with the dull yellow forecolor
 958 dullyellow :: Doc -> Doc
 959 -- | Displays a document with the dull blue forecolor
 960 dullblue :: Doc -> Doc
 961 -- | Displays a document with the dull magenta forecolor
 962 dullmagenta :: Doc -> Doc
 963 -- | Displays a document with the dull cyan forecolor
 964 dullcyan :: Doc -> Doc
 965 -- | Displays a document with the dull white forecolor
 966 dullwhite :: Doc -> Doc
 967 (black, dullblack)     = colorFunctions Black
 968 (red, dullred)         = colorFunctions Red
 969 (green, dullgreen)     = colorFunctions Green
 970 (yellow, dullyellow)   = colorFunctions Yellow
 971 (blue, dullblue)       = colorFunctions Blue
 972 (magenta, dullmagenta) = colorFunctions Magenta
 973 (cyan, dullcyan)       = colorFunctions Cyan
 974 (white, dullwhite)     = colorFunctions White
 975
 976 -- | Displays a document with a forecolor given in the first parameter
 977 color :: Color -> Doc -> Doc
 978 -- | Displays a document with a dull forecolor given in the first parameter
 979 dullcolor :: Color -> Doc -> Doc
 980 color     = Color Foreground Vivid
 981 dullcolor = Color Foreground Dull
 982
 983 colorFunctions :: Color -> (Doc -> Doc, Doc -> Doc)
 984 colorFunctions what = (color what, dullcolor what)
 985
 986 -- | Displays a document with the black backcolor
 987 onblack :: Doc -> Doc
 988 -- | Displays a document with the red backcolor
 989 onred :: Doc -> Doc
 990 -- | Displays a document with the green backcolor
 991 ongreen :: Doc -> Doc
 992 -- | Displays a document with the yellow backcolor
 993 onyellow :: Doc -> Doc
 994 -- | Displays a document with the blue backcolor
 995 onblue :: Doc -> Doc
 996 -- | Displays a document with the magenta backcolor
 997 onmagenta :: Doc -> Doc
 998 -- | Displays a document with the cyan backcolor
 999 oncyan :: Doc -> Doc
1000 -- | Displays a document with the white backcolor
1001 onwhite :: Doc -> Doc
1002 -- | Displays a document with the dull block backcolor
1003 ondullblack :: Doc -> Doc
1004 -- | Displays a document with the dull red backcolor
1005 ondullred :: Doc -> Doc
1006 -- | Displays a document with the dull green backcolor
1007 ondullgreen :: Doc -> Doc
1008 -- | Displays a document with the dull yellow backcolor
1009 ondullyellow :: Doc -> Doc
1010 -- | Displays a document with the dull blue backcolor
1011 ondullblue :: Doc -> Doc
1012 -- | Displays a document with the dull magenta backcolor
1013 ondullmagenta :: Doc -> Doc
1014 -- | Displays a document with the dull cyan backcolor
1015 ondullcyan :: Doc -> Doc
1016 -- | Displays a document with the dull white backcolor
1017 ondullwhite :: Doc -> Doc
1018 (onblack, ondullblack)     = oncolorFunctions Black
1019 (onred, ondullred)         = oncolorFunctions Red
1020 (ongreen, ondullgreen)     = oncolorFunctions Green
1021 (onyellow, ondullyellow)   = oncolorFunctions Yellow
1022 (onblue, ondullblue)       = oncolorFunctions Blue
1023 (onmagenta, ondullmagenta) = oncolorFunctions Magenta
1024 (oncyan, ondullcyan)       = oncolorFunctions Cyan
1025 (onwhite, ondullwhite)     = oncolorFunctions White
1026
1027 -- | Displays a document with a backcolor given in the first parameter
1028 oncolor :: Color -> Doc -> Doc
1029 -- | Displays a document with a dull backcolor given in the first parameter
1030 ondullcolor :: Color -> Doc -> Doc
1031 oncolor     = Color Background Vivid
1032 ondullcolor = Color Background Dull
1033
1034 oncolorFunctions :: Color -> (Doc -> Doc, Doc -> Doc)
1035 oncolorFunctions what = (oncolor what, ondullcolor what)
1036
1037
1038 -----------------------------------------------------------
1039 -- Console Intensity
1040 -----------------------------------------------------------
1041
1042 -- | Displays a document in a heavier font weight
1043 bold :: Doc -> Doc
1044 bold = Intensify BoldIntensity
1045
1046 -- | Displays a document in the normal font weight
1047 debold :: Doc -> Doc
1048 debold = Intensify NormalIntensity
1049
1050 -- NB: I don't support FaintIntensity here because it is not widely supported by terminals.
1051
1052
1053 -----------------------------------------------------------
1054 -- Italicization
1055 -----------------------------------------------------------
1056
1057 {-
1058
1059 I'm in two minds about providing these functions, since italicization is so rarely implemented.
1060 It is especially bad because "italicization" may cause the meaning of colors to flip, which will
1061 look a bit weird, to say the least...
1062
1063
1064 -- | Displays a document in italics. This is not widely supported, and it's use is not recommended
1065 italicize :: Doc -> Doc
1066 italicize = Italicize True
1067
1068 -- | Displays a document with no italics
1069 deitalicize :: Doc -> Doc
1070 deitalicize = Italicize False
1071
1072 -}
1073
1074 -----------------------------------------------------------
1075 -- Underlining
1076 -----------------------------------------------------------
1077
1078 -- | Displays a document with underlining
1079 underline :: Doc -> Doc
1080 underline = Underline SingleUnderline
1081
1082 -- | Displays a document with no underlining
1083 deunderline :: Doc -> Doc
1084 deunderline = Underline NoUnderline
1085
1086 -- NB: I don't support DoubleUnderline here because it is not widely supported by terminals.
1087
1088 -----------------------------------------------------------
1089 -- Removing formatting
1090 -----------------------------------------------------------
1091
1092 -- | Removes all colorisation, emboldening and underlining from a document
1093 plain :: Doc -> Doc
1094 -- plain Fail            = Fail
1095 plain e@Empty         = e
1096 plain c@(Char _)      = c
1097 plain t@(Text _ _)    = t
1098 plain l@(Line _)      = l
1099 -- plain (FlatAlt x y)   = FlatAlt (plain x) (plain y)
1100 plain (Cat x y)       = Cat (plain x) (plain y)
1101 plain (Nest i x)      = Nest i (plain x)
1102 plain (Union x y)     = Union (plain x) (plain y)
1103 plain (Column f)      = Column (plain . f)
1104 -- plain (Columns f)     = Columns (plain . f)
1105 plain (Nesting f)     = Nesting (plain . f)
1106 plain (Spaces l)      = Spaces l
1107 plain (Color _ _ _ x) = plain x
1108 plain (Intensify _ x) = plain x
1109 plain (IfColor _ x)   = plain x
1110 plain (Italicize _ x) = plain x
1111 plain (Underline _ x) = plain x
1112 plain (RestoreFormat _ _ _ _ _) = Empty
1113
1114 -----------------------------------------------------------
1115 -- Renderers
1116 -----------------------------------------------------------
1117
1118 -----------------------------------------------------------
1119 -- renderPretty: the default pretty printing algorithm
1120 -----------------------------------------------------------
1121
1122 -- list of indentation/document pairs; saves an indirection over [(Int,Doc)]
1123 data Docs = Nil
1124           | Cons !Int64 Doc Docs
1125
1126 -- | This is the default pretty printer which is used by 'show',
1127 --   'putDoc' and 'hPutDoc'. @(renderPretty ribbonfrac width x)@
1128 --   renders document @x@ with a page width of @width@ and a ribbon
1129 --   width of @(ribbonfrac * width)@ characters. The ribbon width is
1130 --   the maximal amount of non-indentation characters on a line. The
1131 --   parameter @ribbonfrac@ should be between @0.0@ and @1.0@. If it
1132 --   is lower or higher, the ribbon width will be 0 or @width@
1133 --   respectively.
1134 renderPretty :: Bool -> Float -> Int -> Doc -> SimpleDoc
1135 renderPretty = renderFits fits1
1136
1137 -- | A slightly smarter rendering algorithm with more lookahead. It provides
1138 -- provide earlier breaking on deeply nested structures
1139 -- For example, consider this python-ish pseudocode:
1140 -- @fun(fun(fun(fun(fun([abcdefg, abcdefg])))))@
1141 -- If we put a softbreak (+ nesting 2) after each open parenthesis, and align
1142 -- the elements of the list to match the opening brackets, this will render with
1143 -- @renderPretty@ and a page width of 20 as:
1144 -- @
1145 -- fun(fun(fun(fun(fun([
1146 --                     | abcdef,
1147 --                     | abcdef,
1148 --                     ]
1149 --   )))))             |
1150 -- @
1151 -- Where the 20c. boundary has been marked with |.
1152 -- Because @renderPretty@ only uses one-line lookahead, it sees that the first
1153 -- line fits, and is stuck putting the second and third lines after the 20-c
1154 -- mark. In contrast, @renderSmart@ will continue to check that the potential
1155 -- document up to the end of the indentation level. Thus, it will format the
1156 -- document as:
1157 --
1158 -- @
1159 -- fun(                |
1160 --   fun(              |
1161 --     fun(            |
1162 --       fun(          |
1163 --         fun([       |
1164 --               abcdef,
1165 --               abcdef,
1166 --             ]       |
1167 --   )))))             |
1168 -- @
1169 -- Which fits within the 20c. boundary.
1170 renderSmart :: Bool -> Float -> Int -> Doc -> SimpleDoc
1171 renderSmart = renderFits fitsR
1172
1173 renderFits :: (Int64 -> Int64 -> Int64 -> SimpleDoc -> Bool)
1174            -> Bool -> Float -> Int -> Doc -> SimpleDoc
1175 renderFits fits with_color rfrac w doc
1176     -- I used to do a @SSGR [Reset]@ here, but if you do that it will result
1177     -- in any rendered @Doc@ containing at least some ANSI control codes. This
1178     -- may be undesirable if you want to render to non-ANSI devices by simply
1179     -- not making use of the ANSI color combinators I provide.
1180     --
1181     -- What I "really" want to do here is do an initial Reset iff there is some
1182     -- ANSI color within the Doc, but that's a bit fiddly. I'll fix it if someone
1183     -- complains!
1184     = best 0 0 Nothing Nothing Nothing Nothing Nothing (Cons 0 doc Nil)
1185     where
1186       -- r :: the ribbon width in characters
1187       r = max 0 (min w64 (round (fromIntegral w * rfrac)))
1188
1189       w64 = fromIntegral w
1190
1191       -- best :: n = indentation of current line
1192       --         k = current column
1193       --        (ie. (k >= n) && (k - n == count of inserted characters)
1194       best _n _k _mb_fc _mb_bc _mb_in _mb_it _mb_un Nil = SEmpty
1195       best n k mb_fc mb_bc mb_in mb_it mb_un (Cons i d ds)
1196         = case d of
1197             -- Fail          -> SFail
1198             Empty         -> best_typical n k ds
1199             Char c        -> let k' = k+1 in seq k' (SChar c (best_typical n k' ds))
1200             Text l s      -> let k' = k+l in seq k' (SText l s (best_typical n k' ds))
1201             Line _        -> SLine i (best_typical i i ds)
1202             -- FlatAlt x _   -> best_typical n k (Cons i x ds)
1203             Cat x y       -> best_typical n k (Cons i x (Cons i y ds))
1204             Nest j x      -> let i' = i+j in seq i' (best_typical n k (Cons i' x ds))
1205             Union x y     -> nicest n k (best_typical n k (Cons i x ds))
1206                                         (best_typical n k (Cons i y ds))
1207             Column f      -> best_typical n k (Cons i (f k) ds)
1208             -- Columns f     -> best_typical n k (Cons i (f (Just w)) ds)
1209             Nesting f     -> best_typical n k (Cons i (f i) ds)
1210             Spaces l      -> let k' = k+l in seq k' $ SText l (spaces l) (best_typical n k' ds)
1211             Color _ _ _ x | not with_color -> best_typical n k (Cons i x ds)
1212             Color l t c x -> SSGR [SetColor l t c] (best n k mb_fc' mb_bc' mb_in mb_it mb_un (Cons i x ds_restore))
1213               where
1214                 mb_fc' = case l of { Background -> mb_fc; Foreground -> Just (t, c) }
1215                 mb_bc' = case l of { Background -> Just (t, c); Foreground -> mb_bc }
1216             IfColor xt xf -> best_typical n k (if with_color then Cons i xt ds else Cons i xf ds)
1217             Intensify _ x | not with_color -> best_typical n k (Cons i x ds)
1218             Intensify t x -> SSGR [SetConsoleIntensity t] (best n k mb_fc mb_bc (Just t) mb_it mb_un (Cons i x ds_restore))
1219             Italicize _ x | not with_color -> best_typical n k (Cons i x ds)
1220             Italicize t x -> SSGR [SetItalicized t] (best n k mb_fc mb_bc mb_in (Just t) mb_un (Cons i x ds_restore))
1221             Underline _ x | not with_color -> best_typical n k (Cons i x ds)
1222             Underline u x -> SSGR [SetUnderlining u] (best n k mb_fc mb_bc mb_in mb_it (Just u) (Cons i x ds_restore))
1223             RestoreFormat _ _ _ _ _ | not with_color -> best_typical n k ds
1224             RestoreFormat mb_fc' mb_bc' mb_in' mb_it' mb_un' -> SSGR sgrs (best n k mb_fc' mb_bc' mb_in' mb_it' mb_un' ds)
1225               where
1226                 -- We need to be able to restore the entire SGR state, hence we carry around what we believe
1227                 -- that state should be in all the arguments to this function. Note that in some cases we could
1228                 -- avoid the Reset of the entire state, but not in general.
1229                 sgrs = Reset : catMaybes [
1230                     fmap (uncurry (SetColor Foreground)) mb_fc',
1231                     fmap (uncurry (SetColor Background)) mb_bc',
1232                     fmap SetConsoleIntensity mb_in',
1233                     fmap SetItalicized mb_it',
1234                     fmap SetUnderlining mb_un'
1235                   ]
1236         where
1237           best_typical n' k' ds' = best n' k' mb_fc mb_bc mb_in mb_it mb_un ds'
1238           ds_restore = Cons i (RestoreFormat mb_fc mb_bc mb_in mb_it mb_un) ds
1239
1240       --nicest :: r = ribbon width, w = page width,
1241       --          n = indentation of current line, k = current column
1242       --          x and y, the (simple) documents to chose from.
1243       --          precondition: first lines of x are longer than the first lines of y.
1244       nicest n k x y    | fits w64 (min n k) width_ x  = x
1245                         | otherwise     = y
1246                         where
1247                           width_ = min (w64 - k) (r - k + n)
1248
1249 -- @fits1@ does 1 line lookahead.
1250 fits1 :: Int64 -> Int64 -> Int64 -> SimpleDoc -> Bool
1251 fits1 _ _ w _x        | w < 0         = False
1252 --fits1 _ _ w SFail                    = False
1253 fits1 _ _ _w SEmpty                   = True
1254 fits1 p m w (SChar _c x)              = fits1 p m (w - 1) x
1255 fits1 p m w (SText l _s x)            = fits1 p m (w - l) x
1256 fits1 _ _ _w (SLine _i _x)              = True
1257 fits1 p m w (SSGR _ x)               = fits1 p m w x
1258
1259 -- @fitsR@ has a little more lookahead: assuming that nesting roughly
1260 -- corresponds to syntactic depth, @fitsR@ checks that not only the current line
1261 -- fits, but the entire syntactic structure being formatted at this level of
1262 -- indentation fits. If we were to remove the second case for @SLine@, we would
1263 -- check that not only the current structure fits, but also the rest of the
1264 -- document, which would be slightly more intelligent but would have exponential
1265 -- runtime (and is prohibitively expensive in practice).
1266 -- p = pagewidth
1267 -- m = minimum nesting level to fit in
1268 -- w = the width in which to fit the first line
1269 fitsR :: Int64 -> Int64 -> Int64 -> SimpleDoc -> Bool
1270 fitsR _p _m w _x | w < 0              = False
1271 --fitsR p m w SFail                    = False
1272 fitsR _p _m _w SEmpty                 = True
1273 fitsR p m w (SChar _c x)              = fitsR p m (w - 1) x
1274 fitsR p m w (SText l _s x)            = fitsR p m (w - l) x
1275 fitsR p m _w (SLine i x) | m < i      = fitsR p m (p - i) x
1276                          | otherwise  = True
1277 fitsR p m w (SSGR _ x)                = fitsR p m w x
1278
1279 -----------------------------------------------------------
1280 -- renderCompact: renders documents without indentation
1281 --  fast and fewer characters output, good for machines
1282 -----------------------------------------------------------
1283
1284
1285 -- | @(renderCompact x)@ renders document @x@ without adding any
1286 --   indentation. Since no \'pretty\' printing is involved, this
1287 --   renderer is very fast. The resulting output contains fewer
1288 --   characters than a pretty printed version and can be used for
1289 --   output that is read by other programs.
1290 renderCompact :: Bool -> Doc -> SimpleDoc
1291 renderCompact with_color dc
1292   = scan 0 Nothing Nothing Nothing Nothing Nothing [dc]
1293     where
1294       scan _ _mb_fc _mb_bc _mb_in _mb_it _mb_un [] = SEmpty
1295       scan k mb_fc mb_bc mb_in mb_it mb_un (d:ds)
1296         = case d of
1297             Empty     -> scan' k ds
1298             Char c    -> let k' = k+1 in seq k' (SChar c (scan' k' ds))
1299             Text l s  -> let k' = k+l in seq k' (SText l s (scan' k' ds))
1300             Line _    -> SLine 0 (scan' 0 ds)
1301             -- FlatAlt x _             -> scan' k (x:ds)
1302             Cat x y   -> scan' k (x:y:ds)
1303             Nest _ x  -> scan' k (x:ds)
1304             Union _ y -> scan' k (y:ds)
1305             Column f  -> scan' k (f k:ds)
1306             -- Columns f -> scan' k (f Nothing:ds)
1307             Nesting f -> scan' k (f 0:ds)
1308             Spaces _  -> scan' k ds
1309             Color _ _ _ x | not with_color -> scan' k (x:ds)
1310             Color l t c x -> SSGR [SetColor l t c] (scan k mb_fc' mb_bc' mb_in mb_it mb_un (x:ds_restore))
1311               where
1312                 mb_fc' = case l of { Background -> mb_fc; Foreground -> Just (t, c) }
1313                 mb_bc' = case l of { Background -> Just (t, c); Foreground -> mb_bc }
1314             IfColor   x _ | not with_color -> scan' k (x:ds)
1315             IfColor   _ x              -> scan' k (x:ds)
1316             Intensify _ x | not with_color -> scan' k (x:ds)
1317             Intensify t x -> SSGR [SetConsoleIntensity t] (scan k mb_fc mb_bc (Just t) mb_it mb_un (x:ds_restore))
1318             Italicize _ x | not with_color -> scan' k (x:ds)
1319             Italicize t x -> SSGR [SetItalicized t] (scan k mb_fc mb_bc mb_in (Just t) mb_un (x:ds_restore))
1320             Underline _ x | not with_color -> scan' k (x:ds)
1321             Underline u x -> SSGR [SetUnderlining u] (scan k mb_fc mb_bc mb_in mb_it (Just u) (x:ds_restore))
1322             RestoreFormat _ _ _ _ _ | not with_color -> scan' k ds
1323             RestoreFormat mb_fc' mb_bc' mb_in' mb_it' mb_un' -> SSGR sgrs (scan k mb_fc' mb_bc' mb_in' mb_it' mb_un' ds)
1324               where
1325                 sgrs = Reset : catMaybes [
1326                     fmap (uncurry (SetColor Foreground)) mb_fc',
1327                     fmap (uncurry (SetColor Background)) mb_bc',
1328                     fmap SetConsoleIntensity mb_in',
1329                     fmap SetItalicized mb_it',
1330                     fmap SetUnderlining mb_un'
1331                   ]
1332         where
1333           scan' k' ds' = scan k' mb_fc mb_bc mb_in mb_it mb_un ds'
1334           ds_restore = RestoreFormat mb_fc mb_bc mb_in mb_it mb_un:ds
1335
1336 -- | @(renderOneLine x)@ renders document @x@ without adding any
1337 --   indentation or newlines.
1338 renderOneLine :: Bool -> Doc -> SimpleDoc
1339 renderOneLine with_color dc
1340   = scan 0 Nothing Nothing Nothing Nothing Nothing [dc]
1341     where
1342       scan _ _mb_fc _mb_bc _mb_in _mb_it _mb_un [] = SEmpty
1343       scan k mb_fc mb_bc mb_in mb_it mb_un (d:ds)
1344         = case d of
1345             Empty      -> scan' k ds
1346             Char c     -> let k' = k+1 in seq k' (SChar c (scan' k' ds))
1347             Text l s   -> let k' = k+l in seq k' (SText l s (scan' k' ds))
1348             Line False -> let k' = k+1 in seq k' (SChar ' ' (scan' k' ds))
1349             Line _     -> scan' k ds
1350             Cat x y    -> scan' k (x:y:ds)
1351             Nest _ x   -> scan' k (x:ds)
1352             Union _ y  -> scan' k (y:ds)
1353             Column f   -> scan' k (f k:ds)
1354             Nesting f  -> scan' k (f 0:ds)
1355             Spaces _   -> scan' k ds
1356             Color _ _ _ x | not with_color -> scan' k (x:ds)
1357             Color l t c x -> SSGR [SetColor l t c] (scan k mb_fc' mb_bc' mb_in mb_it mb_un (x:ds_restore))
1358               where
1359                 mb_fc' = case l of { Background -> mb_fc; Foreground -> Just (t, c) }
1360                 mb_bc' = case l of { Background -> Just (t, c); Foreground -> mb_bc }
1361             IfColor x _ | with_color -> scan' k (x:ds)
1362             IfColor _ x              -> scan' k (x:ds)
1363             Intensify _ x | with_color -> scan' k (x:ds)
1364             Intensify t x              -> SSGR [SetConsoleIntensity t] (scan k mb_fc mb_bc (Just t) mb_it mb_un (x:ds_restore))
1365             Italicize _ x | with_color -> scan' k (x:ds)
1366             Italicize t x              -> SSGR [SetItalicized t] (scan k mb_fc mb_bc mb_in (Just t) mb_un (x:ds_restore))
1367             Underline _ x | with_color -> scan' k (x:ds)
1368             Underline u x              -> SSGR [SetUnderlining u] (scan k mb_fc mb_bc mb_in mb_it (Just u) (x:ds_restore))
1369             RestoreFormat _ _ _ _ _ | with_color  -> scan' k ds
1370             RestoreFormat mb_fc' mb_bc' mb_in' mb_it' mb_un' -> SSGR sgrs (scan k mb_fc' mb_bc' mb_in' mb_it' mb_un' ds)
1371               where
1372                 sgrs = Reset : catMaybes [
1373                     fmap (uncurry (SetColor Foreground)) mb_fc',
1374                     fmap (uncurry (SetColor Background)) mb_bc',
1375                     fmap SetConsoleIntensity mb_in',
1376                     fmap SetItalicized mb_it',
1377                     fmap SetUnderlining mb_un'
1378                   ]
1379         where
1380           scan' k' ds' = scan k' mb_fc mb_bc mb_in mb_it mb_un ds'
1381           ds_restore = RestoreFormat mb_fc mb_bc mb_in mb_it mb_un:ds
1382
1383 -----------------------------------------------------------
1384 -- Displayers:  displayS and displayIO
1385 -----------------------------------------------------------
1386
1387
1388 -- | @(displayB simpleDoc)@ takes the output @simpleDoc@ from a
1389 --   rendering function and transforms it to a 'Builder' type (for
1390 --   further manipulation before converting to a lazy 'Text').
1391 displayB               :: SimpleDoc -> Builder
1392 displayB SEmpty        = mempty
1393 displayB (SChar c x)   = c `consB` displayB x
1394 displayB (SText _ s x) = s `mappend` displayB x
1395 displayB (SLine i x)   = '\n' `consB` (indentation i `mappend` displayB x)
1396 displayB (SSGR s x)    = B.fromLazyText (T.pack (setSGRCode s)) `mappend` displayB x
1397
1398 consB :: Char -> Builder -> Builder
1399 c `consB` b = B.singleton c `mappend` b
1400
1401 -- | @(displayT simpleDoc)@ takes the output @simpleDoc@ from a
1402 --   rendering function and transforms it to a lazy 'Text' value.
1403 --
1404 --   > showWidth :: Int -> Doc -> Text
1405 --   > showWidth w x = displayT (renderPretty 0.4 w x)
1406 displayT :: SimpleDoc -> Text
1407 displayT = B.toLazyText . displayB
1408
1409 -- | @(displayIO handle simpleDoc)@ writes @simpleDoc@ to the
1410 --   file handle @handle@. This function is used for example by
1411 --   'hPutDoc':
1412 --
1413 --   > hPutDoc handle doc = displayIO handle (renderPretty 0.4 100 doc)
1414 displayIO :: Handle -> SimpleDoc -> IO ()
1415 displayIO handle simpleDoc
1416  = display simpleDoc
1417     where
1418       display SEmpty        = return ()
1419       display (SChar c x)   = hPutChar handle c >> display x
1420       display (SText _ s x) = T.hPutStr handle (B.toLazyText s) >> display x
1421       display (SLine i x)   = T.hPutStr handle newLine >> display x
1422         where
1423           newLine = B.toLazyText $ '\n' `consB` indentation i
1424       display (SSGR s x)    = hSetSGR handle s >> display x
1425
1426 -----------------------------------------------------------
1427 -- default pretty printers: show, putDoc and hPutDoc
1428 -----------------------------------------------------------
1429
1430 instance Show Doc where
1431   showsPrec d doc = showsPrec d (displayT $ renderPretty True 0.4 80 doc)
1432   show doc = T.unpack (displayT $ renderPretty True 0.4 80 doc)
1433
1434 instance Show SimpleDoc where
1435   show simpleDoc = T.unpack (displayT simpleDoc)
1436
1437 -- | The action @(putDoc doc)@ pretty prints document @doc@ to the
1438 -- standard output, with a page width of 100 characters and a ribbon
1439 -- width of 40 characters.
1440 --
1441 -- > main :: IO ()
1442 -- > main = do{ putDoc (text "hello" <+> text "world") }
1443 --
1444 -- Which would output
1445 --
1446 -- @
1447 -- hello world
1448 -- @
1449 putDoc :: Doc -> IO ()
1450 putDoc doc = hPutDoc stdout doc
1451
1452 -- | @(hPutDoc handle doc)@ pretty prints document @doc@ to the file
1453 --   handle @handle@ with a page width of 100 characters and a ribbon
1454 --   width of 40 characters.
1455 --
1456 --   > main = do handle <- 'openFile' "MyFile" 'WriteMode'
1457 --   >           'hPutDoc' handle ('vcat' ('map' 'text'
1458 --   >                           ['T.pack' "vertical", 'T.pack' "text"]))
1459 --   >           'hClose' handle
1460 hPutDoc :: Handle -> Doc -> IO ()
1461 hPutDoc handle doc = displayIO handle (renderPretty True 0.4 80 doc)
1462
1463 -----------------------------------------------------------
1464 -- insert spaces
1465 -- "indentation" used to insert tabs but tabs seem to cause
1466 -- more trouble than they solve :-)
1467 -----------------------------------------------------------
1468 spaces :: Int64 -> Builder
1469 spaces n
1470   | n <= 0 = mempty
1471   | otherwise = B.fromLazyText $ T.replicate n (T.singleton ' ')
1472
1473 spaced   :: Int -> Doc
1474 spaced l = Spaces l'
1475   where
1476     l' = fromIntegral l
1477
1478 -- An alias for readability purposes
1479 indentation :: Int64 -> Builder
1480 indentation = spaces
1481
1482 -- | Return a 'Doc' from a strict 'Text'
1483 strict_text :: Data.Text.Text -> Doc
1484 strict_text = text . T.fromStrict
1485
1486 -- | Return a 'Doc' concatenating converted values of a 'Foldable'
1487 --   separated by a given 'Doc'.
1488 intercalate
1489  :: Data.Foldable.Foldable t
1490  => Doc -> (a -> Doc) -> t a -> Doc
1491 intercalate separator f =
1492         Data.Foldable.foldl
1493          (\doc x -> doc <> (if is_empty doc then empty else separator) <> f x)
1494          empty
1495
1496 --  LocalWords:  PPrint combinators Wadler Wadler's encloseSep