lib/Hcompta/Lib/Leijen.hs

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