lib/Hcompta/Lib/Leijen.hs

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