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