lib/Hcompta/Lib/Leijen.hs

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