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 above_ :: Doc -> Bool -> Doc -> Doc
 610 above_ p _ Empty = p
 611 above_ Empty _ q = q
 612 above_ p g q = Above p g q
 613
 614 p $$  q = above_ p False q
 615 p $+$ q = above_ p True q
 616
 617 above :: Doc -> Bool -> RDoc -> RDoc
 618 above (Above p g1 q1)  g2 q2 = above p g1 (above q1 g2 q2)
 619 above p@(Beside _ _ _) g  q  = aboveNest (reduceDoc p) g 0 (reduceDoc q)
 620 above p g q                  = aboveNest p             g 0 (reduceDoc q)
 621
 622 aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
 623 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
 624
 625 aboveNest _                   _ k _ | k `seq` False = undefined
 626 aboveNest NoDoc               g k q = NoDoc
 627 aboveNest (p1 `Union` p2)     g k q = aboveNest p1 g k q `union_`
 628                                       aboveNest p2 g k q
 629
 630 aboveNest Empty               g k q = mkNest k q
 631 aboveNest (Nest k1 p)         g k q = nest_ k1 (aboveNest p g (k - k1) q)
 632                                   -- p can't be Empty, so no need for mkNest
 633
 634 aboveNest (NilAbove p)        g k q = nilAbove_ (aboveNest p g k q)
 635 aboveNest (TextBeside s sl p) g k q = k1 `seq` textBeside_ s sl rest
 636                                     where
 637                                       k1   = k - sl
 638                                       rest = case p of
 639                                                 Empty -> nilAboveNest g k1 q
 640                                                 other -> aboveNest  p g k1 q
 641
 642
 643 nilAboveNest :: Bool -> Int -> RDoc -> RDoc
 644 -- Specification: text s <> nilaboveNest g k q
 645 --              = text s <> (text "" $g$ nest k q)
 646
 647 nilAboveNest _ k _           | k `seq` False = undefined
 648 nilAboveNest g k Empty       = Empty    -- Here's why the "text s <>" is in the spec!
 649 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
 650
 651 nilAboveNest g k q           | (not g) && (k > 0)        -- No newline if no overlap
 652                              = textBeside_ (Str (spaces k)) k q
 653                              | otherwise                        -- Put them really above
 654                              = nilAbove_ (mkNest k q)
 655
 656 -- ---------------------------------------------------------------------------
 657 -- Horizontal composition @<>@
 658
 659 beside_ :: Doc -> Bool -> Doc -> Doc
 660 beside_ p _ Empty = p
 661 beside_ Empty _ q = q
 662 beside_ p g q = Beside p g q
 663
 664 p <>  q = beside_ p False q
 665 p <+> q = beside_ p True  q
 666
 667 beside :: Doc -> Bool -> RDoc -> RDoc
 668 -- Specification: beside g p q = p <g> q
 669
 670 beside NoDoc               g q   = NoDoc
 671 beside (p1 `Union` p2)     g q   = (beside p1 g q) `union_` (beside p2 g q)
 672 beside Empty               g q   = q
 673 beside (Nest k p)          g q   = nest_ k (beside p g q)       -- p non-empty
 674 beside p@(Beside p1 g1 q1) g2 q2
 675            {- (A `op1` B) `op2` C == A `op1` (B `op2` C)  iff op1 == op2
 676                                                  [ && (op1 == <> || op1 == <+>) ] -}
 677          | g1 == g2              = beside p1 g1 (beside q1 g2 q2)
 678          | otherwise             = beside (reduceDoc p) g2 q2
 679 beside p@(Above _ _ _)     g q   = beside (reduceDoc p) g q
 680 beside (NilAbove p)        g q   = nilAbove_ (beside p g q)
 681 beside (TextBeside s sl p) g q   = textBeside_ s sl rest
 682                                where
 683                                   rest = case p of
 684                                            Empty -> nilBeside g q
 685                                            other -> beside p g q
 686
 687
 688 nilBeside :: Bool -> RDoc -> RDoc
 689 -- Specification: text "" <> nilBeside g p
 690 --              = text "" <g> p
 691
 692 nilBeside g Empty      = Empty  -- Hence the text "" in the spec
 693 nilBeside g (Nest _ p) = nilBeside g p
 694 nilBeside g p          | g         = textBeside_ space_text 1 p
 695                        | otherwise = p
 696
 697 -- ---------------------------------------------------------------------------
 698 -- Separate, @sep@, Hughes version
 699
 700 -- Specification: sep ps  = oneLiner (hsep ps)
 701 --                         `union`
 702 --                          vcat ps
 703
 704 sep = sepX True         -- Separate with spaces
 705 cat = sepX False        -- Don't
 706
 707 sepX x []     = empty
 708 sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
 709
 710
 711 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
 712 --                            = oneLiner (x <g> nest k (hsep ys))
 713 --                              `union` x $$ nest k (vcat ys)
 714
 715 sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
 716 sep1 g _                   k ys | k `seq` False = undefined
 717 sep1 g NoDoc               k ys = NoDoc
 718 sep1 g (p `Union` q)       k ys = sep1 g p k ys
 719                                   `union_`
 720                                   (aboveNest q False k (reduceDoc (vcat ys)))
 721
 722 sep1 g Empty               k ys = mkNest k (sepX g ys)
 723 sep1 g (Nest n p)          k ys = nest_ n (sep1 g p (k - n) ys)
 724
 725 sep1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
 726 sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)
 727
 728 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
 729 -- Called when we have already found some text in the first item
 730 -- We have to eat up nests
 731
 732 sepNB g (Nest _ p)  k ys  = sepNB g p k ys
 733
 734 sepNB g Empty k ys        = oneLiner (nilBeside g (reduceDoc rest))
 735                                 `mkUnion`
 736                             nilAboveNest False k (reduceDoc (vcat ys))
 737                           where
 738                             rest | g         = hsep ys
 739                                  | otherwise = hcat ys
 740
 741 sepNB g p k ys            = sep1 g p k ys
 742
 743 -- ---------------------------------------------------------------------------
 744 -- @fill@
 745
 746 fsep = fill True
 747 fcat = fill False
 748
 749 -- Specification:
 750 --   fill []  = empty
 751 --   fill [p] = p
 752 --   fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
 753 --                                          (fill (oneLiner p2 : ps))
 754 --                     `union`
 755 --                      p1 $$ fill ps
 756
 757 fill g []     = empty
 758 fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
 759
 760
 761 fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
 762 fill1 g _                   k ys | k `seq` False = undefined
 763 fill1 g NoDoc               k ys = NoDoc
 764 fill1 g (p `Union` q)       k ys = fill1 g p k ys
 765                                    `union_`
 766                                    (aboveNest q False k (fill g ys))
 767
 768 fill1 g Empty               k ys = mkNest k (fill g ys)
 769 fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k - n) ys)
 770
 771 fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fill g ys))
 772 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
 773
 774 fillNB g _           k ys | k `seq` False = undefined
 775 fillNB g (Nest _ p)  k ys  = fillNB g p k ys
 776 fillNB g Empty k []        = Empty
 777 fillNB g Empty k (y:ys)    = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
 778                              `mkUnion`
 779                              nilAboveNest False k (fill g (y:ys))
 780                            where
 781                              k1 | g         = k - 1
 782                                 | otherwise = k
 783
 784 fillNB g p k ys            = fill1 g p k ys
 785
 786
 787 -- ---------------------------------------------------------------------------
 788 -- Selecting the best layout
 789
 790 best :: Mode
 791      -> Int             -- Line length
 792      -> Int             -- Ribbon length
 793      -> RDoc
 794      -> RDoc            -- No unions in here!
 795
 796 best OneLineMode w r p
 797   = get p
 798   where
 799     get Empty               = Empty
 800     get NoDoc               = NoDoc
 801     get (NilAbove p)        = nilAbove_ (get p)
 802     get (TextBeside s sl p) = textBeside_ s sl (get p)
 803     get (Nest k p)          = get p             -- Elide nest
 804     get (p `Union` q)       = first (get p) (get q)
 805
 806 best mode w r p
 807   = get w p
 808   where
 809     get :: Int          -- (Remaining) width of line
 810         -> Doc -> Doc
 811     get w _ | w==0 && False   = undefined
 812     get w Empty               = Empty
 813     get w NoDoc               = NoDoc
 814     get w (NilAbove p)        = nilAbove_ (get w p)
 815     get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
 816     get w (Nest k p)          = nest_ k (get (w - k) p)
 817     get w (p `Union` q)       = nicest w r (get w p) (get w q)
 818
 819     get1 :: Int         -- (Remaining) width of line
 820          -> Int         -- Amount of first line already eaten up
 821          -> Doc         -- This is an argument to TextBeside => eat Nests
 822          -> Doc         -- No unions in here!
 823
 824     get1 w _ _ | w==0 && False = undefined
 825     get1 w sl Empty               = Empty
 826     get1 w sl NoDoc               = NoDoc
 827     get1 w sl (NilAbove p)        = nilAbove_ (get (w - sl) p)
 828     get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)
 829     get1 w sl (Nest k p)          = get1 w sl p
 830     get1 w sl (p `Union` q)       = nicest1 w r sl (get1 w sl p)
 831                                                    (get1 w sl q)
 832
 833 nicest w r p q = nicest1 w r 0 p q
 834 nicest1 w r sl p q | fits ((w `minn` r) - sl) p = p
 835                    | otherwise                   = q
 836
 837 fits :: Int     -- Space available
 838      -> Doc
 839      -> Bool    -- True if *first line* of Doc fits in space available
 840
 841 fits n p    | n < 0 = False
 842 fits n NoDoc               = False
 843 fits n Empty               = True
 844 fits n (NilAbove _)        = True
 845 fits n (TextBeside _ sl p) = fits (n - sl) p
 846
 847 minn x y | x < y    = x
 848          | otherwise = y
 849
 850 -- @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
 851 -- @first@ returns its first argument if it is non-empty, otherwise its second.
 852
 853 first p q | nonEmptySet p = p
 854           | otherwise     = q
 855
 856 nonEmptySet NoDoc           = False
 857 nonEmptySet (p `Union` q)      = True
 858 nonEmptySet Empty              = True
 859 nonEmptySet (NilAbove p)       = True           -- NoDoc always in first line
 860 nonEmptySet (TextBeside _ _ p) = nonEmptySet p
 861 nonEmptySet (Nest _ p)         = nonEmptySet p
 862
 863 -- @oneLiner@ returns the one-line members of the given set of @Doc@s.
 864
 865 oneLiner :: Doc -> Doc
 866 oneLiner NoDoc               = NoDoc
 867 oneLiner Empty               = Empty
 868 oneLiner (NilAbove p)        = NoDoc
 869 oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
 870 oneLiner (Nest k p)          = nest_ k (oneLiner p)
 871 oneLiner (p `Union` q)       = oneLiner p
 872
 873
 874 -- ---------------------------------------------------------------------------
 875 -- Displaying the best layout
 876
 877 renderStyle style doc
 878   = fullRender (mode style)
 879                (lineLength style)
 880                (ribbonsPerLine style)
 881                string_txt
 882                ""
 883                doc
 884
 885 render doc       = showDoc doc ""
 886 showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc
 887
 888 string_txt (Chr c)   s  = c:s
 889 string_txt (Str s1)  s2 = s1 ++ s2
 890 string_txt (PStr s1) s2 = s1 ++ s2
 891
 892
 893 fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc)
 894 fullRender LeftMode    _ _ txt end doc = easy_display nl_text    txt end (reduceDoc doc)
 895
 896 fullRender mode line_length ribbons_per_line txt end doc
 897   = display mode line_length ribbon_length txt end best_doc
 898   where
 899     best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc)
 900
 901     hacked_line_length, ribbon_length :: Int
 902     ribbon_length = round (fromIntegral line_length / ribbons_per_line)
 903     hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length }
 904
 905 display mode page_width ribbon_width txt end doc
 906   = case page_width - ribbon_width of { gap_width ->
 907     case gap_width `quot` 2 of { shift ->
 908     let
 909         lay k _            | k `seq` False = undefined
 910         lay k (Nest k1 p)  = lay (k + k1) p
 911         lay k Empty        = end
 912
 913         lay k (NilAbove p) = nl_text `txt` lay k p
 914
 915         lay k (TextBeside s sl p)
 916             = case mode of
 917                     ZigZagMode |  k >= gap_width
 918                                -> nl_text `txt` (
 919                                   Str (multi_ch shift '/') `txt` (
 920                                   nl_text `txt` (
 921                                   lay1 (k - shift) s sl p)))
 922
 923                                |  k < 0
 924                                -> nl_text `txt` (
 925                                   Str (multi_ch shift '\\') `txt` (
 926                                   nl_text `txt` (
 927                                   lay1 (k + shift) s sl p )))
 928
 929                     other -> lay1 k s sl p
 930
 931         lay1 k _ sl _ | k+sl `seq` False = undefined
 932         lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p)
 933
 934         lay2 k _ | k `seq` False = undefined
 935         lay2 k (NilAbove p)        = nl_text `txt` lay k p
 936         lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p)
 937         lay2 k (Nest _ p)          = lay2 k p
 938         lay2 k Empty               = end
 939     in
 940     lay 0 doc
 941     }}
 942
 943 cant_fail = error "easy_display: NoDoc"
 944 easy_display nl_text txt end doc
 945   = lay doc cant_fail
 946   where
 947     lay NoDoc               no_doc = no_doc
 948     lay (Union p q)         no_doc = {- lay p -} (lay q cant_fail)              -- Second arg can't be NoDoc
 949     lay (Nest k p)          no_doc = lay p no_doc
 950     lay Empty               no_doc = end
 951     lay (NilAbove p)        no_doc = nl_text `txt` lay p cant_fail      -- NoDoc always on first line
 952     lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc
 953
 954 -- OLD version: we shouldn't rely on tabs being 8 columns apart in the output.
 955 -- indent n | n >= 8 = '\t' : indent (n - 8)
 956 --          | otherwise      = spaces n
 957 indent n = spaces n
 958
 959 multi_ch 0 ch = ""
 960 multi_ch n       ch = ch : multi_ch (n - 1) ch
 961
 962 -- (spaces n) generates a list of n spaces
 963 --
 964 -- It should never be called with 'n' < 0, but that can happen for reasons I don't understand
 965 -- Here's a test case:
 966 --      ncat x y = nest 4 $ cat [ x, y ]
 967 --      d1 = foldl1 ncat $ take 50 $ repeat $ char 'a'
 968 --      d2 = parens $  sep [ d1, text "+" , d1 ]
 969 --      main = print d2
 970 -- I don't feel motivated enough to find the Real Bug, so meanwhile we just test for n<=0
 971 spaces n | n <= 0    = ""
 972          | otherwise = ' ' : spaces (n - 1)
 973
 974 {- Comments from Johannes Waldmann about what the problem might be:
 975
 976    In the example above, d2 and d1 are deeply nested, but `text "+"' is not,
 977    so the layout function tries to "out-dent" it.
 978
 979    when I look at the Doc values that are generated, there are lots of
 980    Nest constructors with negative arguments.  see this sample output of
 981    d1 (obtained with hugs, :s -u)
 982
 983    tBeside (TextDetails_Chr 'a') 1 Doc_Empty) (Doc_NilAbove (Doc_Nest
 984    (-241) (Doc_TextBeside (TextDetails_Chr 'a') 1 Doc_Empty)))))
 985    (Doc_NilAbove (Doc_Nest (-236) (Doc_TextBeside (TextDetails_Chr 'a') 1
 986    (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside (TextDetails_Chr 'a') 1
 987    Doc_Empty)))))))) (Doc_NilAbove (Doc_Nest (-231) (Doc_TextBeside
 988    (TextDetails_Chr 'a') 1 (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside
 989    (TextDetails_Chr 'a') 1 (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside
 990    (TextDetails_Chr 'a') 1 Doc_Empty))))))))))) (Doc_NilAbove (Doc_Nest
 991 -}