lib/Hcompta/Format/Text.hs

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