Text/PrettyPrint/HughesPJ.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Text.PrettyPrint.HughesPJ
   4 -- Copyright   :  (c) The University of Glasgow 2001
   5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  provisional
   9 -- Portability :  portable
  10 --
  11 -- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators
  12 --
  13 -- Based on /The Design of a Pretty-printing Library/
  14 -- in Advanced Functional Programming,
  15 -- Johan Jeuring and Erik Meijer (eds), LNCS 925
  16 -- <http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps>
  17 --
  18 -- Heavily modified by Simon Peyton Jones, Dec 96
  19 --
  20 -----------------------------------------------------------------------------
  21
  22 {-
  23 Version 3.0     28 May 1997
  24   * Cured massive performance bug.  If you write
  25
  26         foldl <> empty (map (text.show) [1..10000])
  27
  28     you get quadratic behaviour with V2.0.  Why?  For just the same
  29     reason as you get quadratic behaviour with left-associated (++)
  30     chains.
  31
  32     This is really bad news.  One thing a pretty-printer abstraction
  33     should certainly guarantee is insensivity to associativity.  It
  34     matters: suddenly GHC's compilation times went up by a factor of
  35     100 when I switched to the new pretty printer.
  36
  37     I fixed it with a bit of a hack (because I wanted to get GHC back
  38     on the road).  I added two new constructors to the Doc type, Above
  39     and Beside:
  40
  41          <> = Beside
  42          $$ = Above
  43
  44     Then, where I need to get to a "TextBeside" or "NilAbove" form I
  45     "force" the Doc to squeeze out these suspended calls to Beside and
  46     Above; but in so doing I re-associate. It's quite simple, but I'm
  47     not satisfied that I've done the best possible job.  I'll send you
  48     the code if you are interested.
  49
  50   * Added new exports:
  51         punctuate, hang
  52         int, integer, float, double, rational,
  53         lparen, rparen, lbrack, rbrack, lbrace, rbrace,
  54
  55   * fullRender's type signature has changed.  Rather than producing a
  56     string it now takes an extra couple of arguments that tells it how
  57     to glue fragments of output together:
  58
  59         fullRender :: Mode
  60                    -> Int                       -- Line length
  61                    -> Float                     -- Ribbons per line
  62                    -> (TextDetails -> a -> a)   -- What to do with text
  63                    -> a                         -- What to do at the end
  64                    -> Doc
  65                    -> a                         -- Result
  66
  67     The "fragments" are encapsulated in the TextDetails data type:
  68
  69         data TextDetails = Chr  Char
  70                          | Str  String
  71                          | PStr FAST_STRING
  72
  73     The Chr and Str constructors are obvious enough.  The PStr
  74     constructor has a packed string (FAST_STRING) inside it.  It's
  75     generated by using the new "ptext" export.
  76
  77     An advantage of this new setup is that you can get the renderer to
  78     do output directly (by passing in a function of type (TextDetails
  79     -> IO () -> IO ()), rather than producing a string that you then
  80     print.
  81
  82
  83 Version 2.0     24 April 1997
  84   * Made empty into a left unit for <> as well as a right unit;
  85     it is also now true that
  86         nest k empty = empty
  87     which wasn't true before.
  88
  89   * Fixed an obscure bug in sep that occassionally gave very weird behaviour
  90
  91   * Added $+$
  92
  93   * Corrected and tidied up the laws and invariants
  94
  95 ======================================================================
  96 Relative to John's original paper, there are the following new features:
  97
  98 1.  There's an empty document, "empty".  It's a left and right unit for
  99     both <> and $$, and anywhere in the argument list for
 100     sep, hcat, hsep, vcat, fcat etc.
 101
 102     It is Really Useful in practice.
 103
 104 2.  There is a paragraph-fill combinator, fsep, that's much like sep,
 105     only it keeps fitting things on one line until it can't fit any more.
 106
 107 3.  Some random useful extra combinators are provided.
 108         <+> puts its arguments beside each other with a space between them,
 109             unless either argument is empty in which case it returns the other
 110
 111
 112         hcat is a list version of <>
 113         hsep is a list version of <+>
 114         vcat is a list version of $$
 115
 116         sep (separate) is either like hsep or like vcat, depending on what fits
 117
 118         cat  behaves like sep,  but it uses <> for horizontal conposition
 119         fcat behaves like fsep, but it uses <> for horizontal conposition
 120
 121         These new ones do the obvious things:
 122                 char, semi, comma, colon, space,
 123                 parens, brackets, braces,
 124                 quotes, doubleQuotes
 125
 126 4.  The "above" combinator, $$, now overlaps its two arguments if the
 127     last line of the top argument stops before the first line of the
 128     second begins.
 129
 130         For example:  text "hi" $$ nest 5 (text "there")
 131         lays out as
 132                         hi   there
 133         rather than
 134                         hi
 135                              there
 136
 137         There are two places this is really useful
 138
 139         a) When making labelled blocks, like this:
 140                 Left ->   code for left
 141                 Right ->  code for right
 142                 LongLongLongLabel ->
 143                           code for longlonglonglabel
 144            The block is on the same line as the label if the label is
 145            short, but on the next line otherwise.
 146
 147         b) When laying out lists like this:
 148                 [ first
 149                 , second
 150                 , third
 151                 ]
 152            which some people like.  But if the list fits on one line
 153            you want [first, second, third].  You can't do this with
 154            John's original combinators, but it's quite easy with the
 155            new $$.
 156
 157         The combinator $+$ gives the original "never-overlap" behaviour.
 158
 159 5.      Several different renderers are provided:
 160                 * a standard one
 161                 * one that uses cut-marks to avoid deeply-nested documents
 162                         simply piling up in the right-hand margin
 163                 * one that ignores indentation (fewer chars output; good for machines)
 164                 * one that ignores indentation and newlines (ditto, only more so)
 165
 166 6.      Numerous implementation tidy-ups
 167         Use of unboxed data types to speed up the implementation
 168 -}
 169
 170 module Text.PrettyPrint.HughesPJ (
 171
 172         -- * The document type
 173         Doc,            -- Abstract
 174
 175         -- * Constructing documents
 176         -- ** Converting values into documents
 177         char, text, ptext,
 178         int, integer, float, double, rational,
 179
 180         -- ** Simple derived documents
 181         semi, comma, colon, space, equals,
 182         lparen, rparen, lbrack, rbrack, lbrace, rbrace,
 183
 184         -- ** Wrapping documents in delimiters
 185         parens, brackets, braces, quotes, doubleQuotes,
 186
 187         -- ** Combining documents
 188         empty,
 189         (<>), (<+>), hcat, hsep,
 190         ($$), ($+$), vcat,
 191         sep, cat,
 192         fsep, fcat,
 193         nest,
 194         hang, punctuate,
 195
 196         -- * Predicates on documents
 197         isEmpty,
 198
 199         -- * Rendering documents
 200
 201         -- ** Default rendering
 202         render,
 203
 204         -- ** Rendering with a particular style
 205         Style(..),
 206         style,
 207         renderStyle,
 208
 209         -- ** General rendering
 210         fullRender,
 211         Mode(..), TextDetails(..),
 212
 213   ) where
 214
 215
 216 import Prelude
 217
 218 infixl 6 <>
 219 infixl 6 <+>
 220 infixl 5 $$, $+$
 221
 222 -- ---------------------------------------------------------------------------
 223 -- The interface
 224
 225 -- The primitive Doc values
 226
 227 isEmpty :: Doc    -> Bool;  -- ^ Returns 'True' if the document is empty
 228
 229 -- | The empty document, with no height and no width.
 230 -- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere
 231 -- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc.
 232 empty   :: Doc
 233
 234 semi    :: Doc;                 -- ^ A ';' character
 235 comma   :: Doc;                 -- ^ A ',' character
 236 colon   :: Doc;                 -- ^ A ':' character
 237 space   :: Doc;                 -- ^ A space character
 238 equals  :: Doc;                 -- ^ A '=' character
 239 lparen  :: Doc;                 -- ^ A '(' character
 240 rparen  :: Doc;                 -- ^ A ')' character
 241 lbrack  :: Doc;                 -- ^ A '[' character
 242 rbrack  :: Doc;                 -- ^ A ']' character
 243 lbrace  :: Doc;                 -- ^ A '{' character
 244 rbrace  :: Doc;                 -- ^ A '}' character
 245
 246 -- | A document of height and width 1, containing a literal character.
 247 char     :: Char     -> Doc
 248
 249 -- | A document of height 1 containing a literal string.
 250 -- 'text' satisfies the following laws:
 251 --
 252 -- * @'text' s '<>' 'text' t = 'text' (s'++'t)@
 253 --
 254 -- * @'text' \"\" '<>' x = x@, if @x@ non-empty
 255 --
 256 -- The side condition on the last law is necessary because @'text' \"\"@
 257 -- has height 1, while 'empty' has no height.
 258 text     :: String   -> Doc
 259
 260 -- | An obsolete function, now identical to 'text'.
 261 ptext    :: String   -> Doc
 262
 263 int      :: Int      -> Doc;    -- ^ @int n = text (show n)@
 264 integer  :: Integer  -> Doc;    -- ^ @integer n = text (show n)@
 265 float    :: Float    -> Doc;    -- ^ @float n = text (show n)@
 266 double   :: Double   -> Doc;    -- ^ @double n = text (show n)@
 267 rational :: Rational -> Doc;    -- ^ @rational n = text (show n)@
 268
 269 parens       :: Doc -> Doc;     -- ^ Wrap document in @(...)@
 270 brackets     :: Doc -> Doc;     -- ^ Wrap document in @[...]@
 271 braces       :: Doc -> Doc;     -- ^ Wrap document in @{...}@
 272 quotes       :: Doc -> Doc;     -- ^ Wrap document in @\'...\'@
 273 doubleQuotes :: Doc -> Doc;     -- ^ Wrap document in @\"...\"@
 274
 275 -- Combining @Doc@ values
 276
 277 -- | Beside.
 278 -- '<>' is associative, with identity 'empty'.
 279 (<>)   :: Doc -> Doc -> Doc
 280
 281 -- | Beside, separated by space, unless one of the arguments is 'empty'.
 282 -- '<+>' is associative, with identity 'empty'.
 283 (<+>)  :: Doc -> Doc -> Doc
 284
 285 -- | Above, except that if the last line of the first argument stops
 286 -- at least one position before the first line of the second begins,
 287 -- these two lines are overlapped.  For example:
 288 --
 289 -- >    text "hi" $$ nest 5 (text "there")
 290 --
 291 -- lays out as
 292 --
 293 -- >    hi   there
 294 --
 295 -- rather than
 296 --
 297 -- >    hi
 298 -- >         there
 299 --
 300 -- '$$' is associative, with identity 'empty', and also satisfies
 301 --
 302 -- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty.
 303 --
 304 ($$)   :: Doc -> Doc -> Doc
 305
 306 -- | Above, with no overlapping.
 307 -- '$+$' is associative, with identity 'empty'.
 308 ($+$)   :: Doc -> Doc -> Doc
 309
 310 hcat   :: [Doc] -> Doc;          -- ^List version of '<>'.
 311 hsep   :: [Doc] -> Doc;          -- ^List version of '<+>'.
 312 vcat   :: [Doc] -> Doc;          -- ^List version of '$$'.
 313
 314 cat    :: [Doc] -> Doc;          -- ^ Either 'hcat' or 'vcat'.
 315 sep    :: [Doc] -> Doc;          -- ^ Either 'hsep' or 'vcat'.
 316 fcat   :: [Doc] -> Doc;          -- ^ \"Paragraph fill\" version of 'cat'.
 317 fsep   :: [Doc] -> Doc;          -- ^ \"Paragraph fill\" version of 'sep'.
 318
 319 -- | Nest (or indent) a document by a given number of positions
 320 -- (which may also be negative).  'nest' satisfies the laws:
 321 --
 322 -- * @'nest' 0 x = x@
 323 --
 324 -- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@
 325 --
 326 -- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@
 327 --
 328 -- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@
 329 --
 330 -- * @'nest' k 'empty' = 'empty'@
 331 --
 332 -- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty
 333 --
 334 -- The side condition on the last law is needed because
 335 -- 'empty' is a left identity for '<>'.
 336 nest   :: Int -> Doc -> Doc
 337
 338 -- GHC-specific ones.
 339
 340 -- | @hang d1 n d2 = sep [d1, nest n d2]@
 341 hang :: Doc -> Int -> Doc -> Doc
 342
 343 -- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@
 344 punctuate :: Doc -> [Doc] -> [Doc]
 345
 346
 347 -- Displaying @Doc@ values.
 348
 349 instance Show Doc where
 350   showsPrec prec doc cont = showDoc doc cont
 351
 352 -- | Renders the document as a string using the default 'style'.
 353 render     :: Doc -> String
 354
 355 -- | The general rendering interface.
 356 fullRender :: Mode                      -- ^Rendering mode
 357            -> Int                       -- ^Line length
 358            -> Float                     -- ^Ribbons per line
 359            -> (TextDetails -> a -> a)   -- ^What to do with text
 360            -> a                         -- ^What to do at the end
 361            -> Doc                       -- ^The document
 362            -> a                         -- ^Result
 363
 364 -- | Render the document as a string using a specified style.
 365 renderStyle  :: Style -> Doc -> String
 366
 367 -- | A rendering style.
 368 data Style
 369  = Style { mode           :: Mode     -- ^ The rendering mode
 370          , lineLength     :: Int      -- ^ Length of line, in chars
 371          , ribbonsPerLine :: Float    -- ^ Ratio of ribbon length to line length
 372          }
 373
 374 -- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@).
 375 style :: Style
 376 style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode }
 377
 378 -- | Rendering mode.
 379 data Mode = PageMode            -- ^Normal
 380           | ZigZagMode          -- ^With zig-zag cuts
 381           | LeftMode            -- ^No indentation, infinitely long lines
 382           | OneLineMode         -- ^All on one line
 383
 384 -- ---------------------------------------------------------------------------
 385 -- The Doc calculus
 386
 387 -- The Doc combinators satisfy the following laws:
 388
 389 {-
 390 Laws for $$
 391 ~~~~~~~~~~~
 392 <a1>    (x $$ y) $$ z   = x $$ (y $$ z)
 393 <a2>    empty $$ x      = x
 394 <a3>    x $$ empty      = x
 395
 396         ...ditto $+$...
 397
 398 Laws for <>
 399 ~~~~~~~~~~~
 400 <b1>    (x <> y) <> z   = x <> (y <> z)
 401 <b2>    empty <> x      = empty
 402 <b3>    x <> empty      = x
 403
 404         ...ditto <+>...
 405
 406 Laws for text
 407 ~~~~~~~~~~~~~
 408 <t1>    text s <> text t        = text (s++t)
 409 <t2>    text "" <> x            = x, if x non-empty
 410
 411 Laws for nest
 412 ~~~~~~~~~~~~~
 413 <n1>    nest 0 x                = x
 414 <n2>    nest k (nest k' x)      = nest (k+k') x
 415 <n3>    nest k (x <> y)         = nest k z <> nest k y
 416 <n4>    nest k (x $$ y)         = nest k x $$ nest k y
 417 <n5>    nest k empty            = empty
 418 <n6>    x <> nest k y           = x <> y, if x non-empty
 419
 420 ** Note the side condition on <n6>!  It is this that
 421 ** makes it OK for empty to be a left unit for <>.
 422
 423 Miscellaneous
 424 ~~~~~~~~~~~~~
 425 <m1>    (text s <> x) $$ y = text s <> ((text "" <> x)) $$
 426                                          nest (-length s) y)
 427
 428 <m2>    (x $$ y) <> z = x $$ (y <> z)
 429         if y non-empty
 430
 431
 432 Laws for list versions
 433 ~~~~~~~~~~~~~~~~~~~~~~
 434 <l1>    sep (ps++[empty]++qs)   = sep (ps ++ qs)
 435         ...ditto hsep, hcat, vcat, fill...
 436
 437 <l2>    nest k (sep ps) = sep (map (nest k) ps)
 438         ...ditto hsep, hcat, vcat, fill...
 439
 440 Laws for oneLiner
 441 ~~~~~~~~~~~~~~~~~
 442 <o1>    oneLiner (nest k p) = nest k (oneLiner p)
 443 <o2>    oneLiner (x <> y)   = oneLiner x <> oneLiner y
 444
 445 You might think that the following verion of <m1> would
 446 be neater:
 447
 448 <3 NO>  (text s <> x) $$ y = text s <> ((empty <> x)) $$
 449                                          nest (-length s) y)
 450
 451 But it doesn't work, for if x=empty, we would have
 452
 453         text s $$ y = text s <> (empty $$ nest (-length s) y)
 454                     = text s <> nest (-length s) y
 455 -}
 456
 457 -- ---------------------------------------------------------------------------
 458 -- Simple derived definitions
 459
 460 semi  = char ';'
 461 colon = char ':'
 462 comma = char ','
 463 space = char ' '
 464 equals = char '='
 465 lparen = char '('
 466 rparen = char ')'
 467 lbrack = char '['
 468 rbrack = char ']'
 469 lbrace = char '{'
 470 rbrace = char '}'
 471
 472 int      n = text (show n)
 473 integer  n = text (show n)
 474 float    n = text (show n)
 475 double   n = text (show n)
 476 rational n = text (show n)
 477 -- SIGBJORN wrote instead:
 478 -- rational n = text (show (fromRationalX n))
 479
 480 quotes p        = char '\'' <> p <> char '\''
 481 doubleQuotes p  = char '"' <> p <> char '"'
 482 parens p        = char '(' <> p <> char ')'
 483 brackets p      = char '[' <> p <> char ']'
 484 braces p        = char '{' <> p <> char '}'
 485
 486
 487 hcat = foldr (<>)  empty
 488 hsep = foldr (<+>) empty
 489 vcat = foldr ($$)  empty
 490
 491 hang d1 n d2 = sep [d1, nest n d2]
 492
 493 punctuate p []     = []
 494 punctuate p (d:ds) = go d ds
 495                    where
 496                      go d [] = [d]
 497                      go d (e:es) = (d <> p) : go e es
 498
 499 -- ---------------------------------------------------------------------------
 500 -- The Doc data type
 501
 502 -- A Doc represents a *set* of layouts.  A Doc with
 503 -- no occurrences of Union or NoDoc represents just one layout.
 504
 505 -- | The abstract type of documents.
 506 -- The 'Show' instance is equivalent to using 'render'.
 507 data Doc
 508  = Empty                                -- empty
 509  | NilAbove Doc                         -- text "" $$ x
 510  | TextBeside TextDetails !Int Doc      -- text s <> x
 511  | Nest !Int Doc                        -- nest k x
 512  | Union Doc Doc                        -- ul `union` ur
 513  | NoDoc                                -- The empty set of documents
 514  | Beside Doc Bool Doc                  -- True <=> space between
 515  | Above  Doc Bool Doc                  -- True <=> never overlap
 516
 517 type RDoc = Doc         -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
 518
 519
 520 reduceDoc :: Doc -> RDoc
 521 reduceDoc (Beside p g q) = beside p g (reduceDoc q)
 522 reduceDoc (Above  p g q) = above  p g (reduceDoc q)
 523 reduceDoc p              = p
 524
 525
 526 data TextDetails = Chr  Char
 527                  | Str  String
 528                  | PStr String
 529 space_text = Chr ' '
 530 nl_text    = Chr '\n'
 531
 532 {-
 533   Here are the invariants:
 534
 535   * The argument of NilAbove is never Empty. Therefore
 536     a NilAbove occupies at least two lines.
 537
 538   * The arugment of @TextBeside@ is never @Nest@.
 539
 540
 541   * The layouts of the two arguments of @Union@ both flatten to the same
 542     string.
 543
 544   * The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
 545
 546   * The right argument of a union cannot be equivalent to the empty set
 547     (@NoDoc@).  If the left argument of a union is equivalent to the
 548     empty set (@NoDoc@), then the @NoDoc@ appears in the first line.
 549
 550   * An empty document is always represented by @Empty@.  It can't be
 551     hidden inside a @Nest@, or a @Union@ of two @Empty@s.
 552
 553   * The first line of every layout in the left argument of @Union@ is
 554     longer than the first line of any layout in the right argument.
 555     (1) ensures that the left argument has a first line.  In view of
 556     (3), this invariant means that the right argument must have at
 557     least two lines.
 558 -}
 559
 560         -- Arg of a NilAbove is always an RDoc
 561 nilAbove_ p = NilAbove p
 562
 563         -- Arg of a TextBeside is always an RDoc
 564 textBeside_ s sl p = TextBeside s sl p
 565
 566         -- Arg of Nest is always an RDoc
 567 nest_ k p = Nest k p
 568
 569         -- Args of union are always RDocs
 570 union_ p q = Union p q
 571
 572
 573 -- Notice the difference between
 574 --         * NoDoc (no documents)
 575 --         * Empty (one empty document; no height and no width)
 576 --         * text "" (a document containing the empty string;
 577 --                    one line high, but has no width)
 578
 579
 580 -- ---------------------------------------------------------------------------
 581 -- @empty@, @text@, @nest@, @union@
 582
 583 empty = Empty
 584
 585 isEmpty Empty = True
 586 isEmpty _     = False
 587
 588 char  c = textBeside_ (Chr c) 1 Empty
 589 text  s = case length s of {sl -> textBeside_ (Str s)  sl Empty}
 590 ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty}
 591
 592 nest k  p = mkNest k (reduceDoc p)        -- Externally callable version
 593
 594 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
 595 mkNest k       _           | k `seq` False = undefined
 596 mkNest k       (Nest k1 p) = mkNest (k + k1) p
 597 mkNest k       NoDoc       = NoDoc
 598 mkNest k       Empty       = Empty
 599 mkNest 0       p           = p                  -- Worth a try!
 600 mkNest k       p           = nest_ k p
 601
 602 -- mkUnion checks for an empty document
 603 mkUnion Empty q = Empty
 604 mkUnion p q     = p `union_` q
 605
 606 -- ---------------------------------------------------------------------------
 607 -- Vertical composition @$$@
 608
 609 p $$  q = Above p False q
 610 p $+$ q = Above p True q
 611
 612 above :: Doc -> Bool -> RDoc -> RDoc
 613 above (Above p g1 q1)  g2 q2 = above p g1 (above q1 g2 q2)
 614 above p@(Beside _ _ _) g  q  = aboveNest (reduceDoc p) g 0 (reduceDoc q)
 615 above p g q                  = aboveNest p             g 0 (reduceDoc q)
 616
 617 aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
 618 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
 619
 620 aboveNest _                   _ k _ | k `seq` False = undefined
 621 aboveNest NoDoc               g k q = NoDoc
 622 aboveNest (p1 `Union` p2)     g k q = aboveNest p1 g k q `union_`
 623                                       aboveNest p2 g k q
 624
 625 aboveNest Empty               g k q = mkNest k q
 626 aboveNest (Nest k1 p)         g k q = nest_ k1 (aboveNest p g (k - k1) q)
 627                                   -- p can't be Empty, so no need for mkNest
 628
 629 aboveNest (NilAbove p)        g k q = nilAbove_ (aboveNest p g k q)
 630 aboveNest (TextBeside s sl p) g k q = k1 `seq` textBeside_ s sl rest
 631                                     where
 632                                       k1   = k - sl
 633                                       rest = case p of
 634                                                 Empty -> nilAboveNest g k1 q
 635                                                 other -> aboveNest  p g k1 q
 636
 637
 638 nilAboveNest :: Bool -> Int -> RDoc -> RDoc
 639 -- Specification: text s <> nilaboveNest g k q
 640 --              = text s <> (text "" $g$ nest k q)
 641
 642 nilAboveNest _ k _           | k `seq` False = undefined
 643 nilAboveNest g k Empty       = Empty    -- Here's why the "text s <>" is in the spec!
 644 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
 645
 646 nilAboveNest g k q           | (not g) && (k > 0)        -- No newline if no overlap
 647                              = textBeside_ (Str (spaces k)) k q
 648                              | otherwise                        -- Put them really above
 649                              = nilAbove_ (mkNest k q)
 650
 651 -- ---------------------------------------------------------------------------
 652 -- Horizontal composition @<>@
 653
 654 p <>  q = Beside p False q
 655 p <+> q = Beside p True  q
 656
 657 beside :: Doc -> Bool -> RDoc -> RDoc
 658 -- Specification: beside g p q = p <g> q
 659
 660 beside NoDoc               g q   = NoDoc
 661 beside (p1 `Union` p2)     g q   = (beside p1 g q) `union_` (beside p2 g q)
 662 beside Empty               g q   = q
 663 beside (Nest k p)          g q   = nest_ k (beside p g q)       -- p non-empty
 664 beside p@(Beside p1 g1 q1) g2 q2
 665            {- (A `op1` B) `op2` C == A `op1` (B `op2` C)  iff op1 == op2
 666                                                  [ && (op1 == <> || op1 == <+>) ] -}
 667          | g1 == g2              = beside p1 g1 (beside q1 g2 q2)
 668          | otherwise             = beside (reduceDoc p) g2 q2
 669 beside p@(Above _ _ _)     g q   = beside (reduceDoc p) g q
 670 beside (NilAbove p)        g q   = nilAbove_ (beside p g q)
 671 beside (TextBeside s sl p) g q   = textBeside_ s sl rest
 672                                where
 673                                   rest = case p of
 674                                            Empty -> nilBeside g q
 675                                            other -> beside p g q
 676
 677
 678 nilBeside :: Bool -> RDoc -> RDoc
 679 -- Specification: text "" <> nilBeside g p
 680 --              = text "" <g> p
 681
 682 nilBeside g Empty      = Empty  -- Hence the text "" in the spec
 683 nilBeside g (Nest _ p) = nilBeside g p
 684 nilBeside g p          | g         = textBeside_ space_text 1 p
 685                        | otherwise = p
 686
 687 -- ---------------------------------------------------------------------------
 688 -- Separate, @sep@, Hughes version
 689
 690 -- Specification: sep ps  = oneLiner (hsep ps)
 691 --                         `union`
 692 --                          vcat ps
 693
 694 sep = sepX True         -- Separate with spaces
 695 cat = sepX False        -- Don't
 696
 697 sepX x []     = empty
 698 sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
 699
 700
 701 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
 702 --                            = oneLiner (x <g> nest k (hsep ys))
 703 --                              `union` x $$ nest k (vcat ys)
 704
 705 sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
 706 sep1 g _                   k ys | k `seq` False = undefined
 707 sep1 g NoDoc               k ys = NoDoc
 708 sep1 g (p `Union` q)       k ys = sep1 g p k ys
 709                                   `union_`
 710                                   (aboveNest q False k (reduceDoc (vcat ys)))
 711
 712 sep1 g Empty               k ys = mkNest k (sepX g ys)
 713 sep1 g (Nest n p)          k ys = nest_ n (sep1 g p (k - n) ys)
 714
 715 sep1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
 716 sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)
 717
 718 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
 719 -- Called when we have already found some text in the first item
 720 -- We have to eat up nests
 721
 722 sepNB g (Nest _ p)  k ys  = sepNB g p k ys
 723
 724 sepNB g Empty k ys        = oneLiner (nilBeside g (reduceDoc rest))
 725                                 `mkUnion`
 726                             nilAboveNest False k (reduceDoc (vcat ys))
 727                           where
 728                             rest | g         = hsep ys
 729                                  | otherwise = hcat ys
 730
 731 sepNB g p k ys            = sep1 g p k ys
 732
 733 -- ---------------------------------------------------------------------------
 734 -- @fill@
 735
 736 fsep = fill True
 737 fcat = fill False
 738
 739 -- Specification:
 740 --   fill []  = empty
 741 --   fill [p] = p
 742 --   fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
 743 --                                          (fill (oneLiner p2 : ps))
 744 --                     `union`
 745 --                      p1 $$ fill ps
 746
 747 fill g []     = empty
 748 fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
 749
 750
 751 fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
 752 fill1 g _                   k ys | k `seq` False = undefined
 753 fill1 g NoDoc               k ys = NoDoc
 754 fill1 g (p `Union` q)       k ys = fill1 g p k ys
 755                                    `union_`
 756                                    (aboveNest q False k (fill g ys))
 757
 758 fill1 g Empty               k ys = mkNest k (fill g ys)
 759 fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k - n) ys)
 760
 761 fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fill g ys))
 762 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
 763
 764 fillNB g _           k ys | k `seq` False = undefined
 765 fillNB g (Nest _ p)  k ys  = fillNB g p k ys
 766 fillNB g Empty k []        = Empty
 767 fillNB g Empty k (y:ys)    = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
 768                              `mkUnion`
 769                              nilAboveNest False k (fill g (y:ys))
 770                            where
 771                              k1 | g         = k - 1
 772                                 | otherwise = k
 773
 774 fillNB g p k ys            = fill1 g p k ys
 775
 776
 777 -- ---------------------------------------------------------------------------
 778 -- Selecting the best layout
 779
 780 best :: Mode
 781      -> Int             -- Line length
 782      -> Int             -- Ribbon length
 783      -> RDoc
 784      -> RDoc            -- No unions in here!
 785
 786 best OneLineMode w r p
 787   = get p
 788   where
 789     get Empty               = Empty
 790     get NoDoc               = NoDoc
 791     get (NilAbove p)        = nilAbove_ (get p)
 792     get (TextBeside s sl p) = textBeside_ s sl (get p)
 793     get (Nest k p)          = get p             -- Elide nest
 794     get (p `Union` q)       = first (get p) (get q)
 795
 796 best mode w r p
 797   = get w p
 798   where
 799     get :: Int          -- (Remaining) width of line
 800         -> Doc -> Doc
 801     get w _ | w==0 && False   = undefined
 802     get w Empty               = Empty
 803     get w NoDoc               = NoDoc
 804     get w (NilAbove p)        = nilAbove_ (get w p)
 805     get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
 806     get w (Nest k p)          = nest_ k (get (w - k) p)
 807     get w (p `Union` q)       = nicest w r (get w p) (get w q)
 808
 809     get1 :: Int         -- (Remaining) width of line
 810          -> Int         -- Amount of first line already eaten up
 811          -> Doc         -- This is an argument to TextBeside => eat Nests
 812          -> Doc         -- No unions in here!
 813
 814     get1 w _ _ | w==0 && False = undefined
 815     get1 w sl Empty               = Empty
 816     get1 w sl NoDoc               = NoDoc
 817     get1 w sl (NilAbove p)        = nilAbove_ (get (w - sl) p)
 818     get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)
 819     get1 w sl (Nest k p)          = get1 w sl p
 820     get1 w sl (p `Union` q)       = nicest1 w r sl (get1 w sl p)
 821                                                    (get1 w sl q)
 822
 823 nicest w r p q = nicest1 w r 0 p q
 824 nicest1 w r sl p q | fits ((w `minn` r) - sl) p = p
 825                    | otherwise                   = q
 826
 827 fits :: Int     -- Space available
 828      -> Doc
 829      -> Bool    -- True if *first line* of Doc fits in space available
 830
 831 fits n p    | n < 0 = False
 832 fits n NoDoc               = False
 833 fits n Empty               = True
 834 fits n (NilAbove _)        = True
 835 fits n (TextBeside _ sl p) = fits (n - sl) p
 836
 837 minn x y | x < y    = x
 838          | otherwise = y
 839
 840 -- @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
 841 -- @first@ returns its first argument if it is non-empty, otherwise its second.
 842
 843 first p q | nonEmptySet p = p
 844           | otherwise     = q
 845
 846 nonEmptySet NoDoc           = False
 847 nonEmptySet (p `Union` q)      = True
 848 nonEmptySet Empty              = True
 849 nonEmptySet (NilAbove p)       = True           -- NoDoc always in first line
 850 nonEmptySet (TextBeside _ _ p) = nonEmptySet p
 851 nonEmptySet (Nest _ p)         = nonEmptySet p
 852
 853 -- @oneLiner@ returns the one-line members of the given set of @Doc@s.
 854
 855 oneLiner :: Doc -> Doc
 856 oneLiner NoDoc               = NoDoc
 857 oneLiner Empty               = Empty
 858 oneLiner (NilAbove p)        = NoDoc
 859 oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
 860 oneLiner (Nest k p)          = nest_ k (oneLiner p)
 861 oneLiner (p `Union` q)       = oneLiner p
 862
 863
 864 -- ---------------------------------------------------------------------------
 865 -- Displaying the best layout
 866
 867 renderStyle style doc
 868   = fullRender (mode style)
 869                (lineLength style)
 870                (ribbonsPerLine style)
 871                string_txt
 872                ""
 873                doc
 874
 875 render doc       = showDoc doc ""
 876 showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc
 877
 878 string_txt (Chr c)   s  = c:s
 879 string_txt (Str s1)  s2 = s1 ++ s2
 880 string_txt (PStr s1) s2 = s1 ++ s2
 881
 882
 883 fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc)
 884 fullRender LeftMode    _ _ txt end doc = easy_display nl_text    txt end (reduceDoc doc)
 885
 886 fullRender mode line_length ribbons_per_line txt end doc
 887   = display mode line_length ribbon_length txt end best_doc
 888   where
 889     best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc)
 890
 891     hacked_line_length, ribbon_length :: Int
 892     ribbon_length = round (fromIntegral line_length / ribbons_per_line)
 893     hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length }
 894
 895 display mode page_width ribbon_width txt end doc
 896   = case page_width - ribbon_width of { gap_width ->
 897     case gap_width `quot` 2 of { shift ->
 898     let
 899         lay k _            | k `seq` False = undefined
 900         lay k (Nest k1 p)  = lay (k + k1) p
 901         lay k Empty        = end
 902
 903         lay k (NilAbove p) = nl_text `txt` lay k p
 904
 905         lay k (TextBeside s sl p)
 906             = case mode of
 907                     ZigZagMode |  k >= gap_width
 908                                -> nl_text `txt` (
 909                                   Str (multi_ch shift '/') `txt` (
 910                                   nl_text `txt` (
 911                                   lay1 (k - shift) s sl p)))
 912
 913                                |  k < 0
 914                                -> nl_text `txt` (
 915                                   Str (multi_ch shift '\\') `txt` (
 916                                   nl_text `txt` (
 917                                   lay1 (k + shift) s sl p )))
 918
 919                     other -> lay1 k s sl p
 920
 921         lay1 k _ sl _ | k+sl `seq` False = undefined
 922         lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p)
 923
 924         lay2 k _ | k `seq` False = undefined
 925         lay2 k (NilAbove p)        = nl_text `txt` lay k p
 926         lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p)
 927         lay2 k (Nest _ p)          = lay2 k p
 928         lay2 k Empty               = end
 929     in
 930     lay 0 doc
 931     }}
 932
 933 cant_fail = error "easy_display: NoDoc"
 934 easy_display nl_text txt end doc
 935   = lay doc cant_fail
 936   where
 937     lay NoDoc               no_doc = no_doc
 938     lay (Union p q)         no_doc = {- lay p -} (lay q cant_fail)              -- Second arg can't be NoDoc
 939     lay (Nest k p)          no_doc = lay p no_doc
 940     lay Empty               no_doc = end
 941     lay (NilAbove p)        no_doc = nl_text `txt` lay p cant_fail      -- NoDoc always on first line
 942     lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc
 943
 944 -- OLD version: we shouldn't rely on tabs being 8 columns apart in the output.
 945 -- indent n | n >= 8 = '\t' : indent (n - 8)
 946 --          | otherwise      = spaces n
 947 indent n = spaces n
 948
 949 multi_ch 0 ch = ""
 950 multi_ch n       ch = ch : multi_ch (n - 1) ch
 951
 952 -- (spaces n) generates a list of n spaces
 953 --
 954 -- It should never be called with 'n' < 0, but that can happen for reasons I don't understand
 955 -- Here's a test case:
 956 --      ncat x y = nest 4 $ cat [ x, y ]
 957 --      d1 = foldl1 ncat $ take 50 $ repeat $ char 'a'
 958 --      d2 = parens $  sep [ d1, text "+" , d1 ]
 959 --      main = print d2
 960 -- I don't feel motivated enough to find the Real Bug, so meanwhile we just test for n<=0
 961 spaces n | n <= 0    = ""
 962          | otherwise = ' ' : spaces (n - 1)
 963
 964 {- Comments from Johannes Waldmann about what the problem might be:
 965
 966    In the example above, d2 and d1 are deeply nested, but `text "+"' is not,
 967    so the layout function tries to "out-dent" it.
 968
 969    when I look at the Doc values that are generated, there are lots of
 970    Nest constructors with negative arguments.  see this sample output of
 971    d1 (obtained with hugs, :s -u)
 972
 973    tBeside (TextDetails_Chr 'a') 1 Doc_Empty) (Doc_NilAbove (Doc_Nest
 974    (-241) (Doc_TextBeside (TextDetails_Chr 'a') 1 Doc_Empty)))))
 975    (Doc_NilAbove (Doc_Nest (-236) (Doc_TextBeside (TextDetails_Chr 'a') 1
 976    (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside (TextDetails_Chr 'a') 1
 977    Doc_Empty)))))))) (Doc_NilAbove (Doc_Nest (-231) (Doc_TextBeside
 978    (TextDetails_Chr 'a') 1 (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside
 979    (TextDetails_Chr 'a') 1 (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside
 980    (TextDetails_Chr 'a') 1 Doc_Empty))))))))))) (Doc_NilAbove (Doc_Nest
 981 -}