ghc/compiler/utils/Pretty.lhs

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