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, printDoc
 176   ) where
 177
 178 #include "HsVersions.h"
 179
 180 import FastString
 181 import GlaExts
 182 import Numeric (fromRat)
 183 import IO
 184
 185 -- Don't import Util( assertPanic ) because it makes a loop in the module structure
 186
 187 infixl 6 <>
 188 infixl 6 <+>
 189 infixl 5 $$, $+$
 190 \end{code}
 191
 192
 193
 194 *********************************************************
 195 *                                                       *
 196 \subsection{CPP magic so that we can compile with both GHC and Hugs}
 197 *                                                       *
 198 *********************************************************
 199
 200 The library uses unboxed types to get a bit more speed, but these CPP macros
 201 allow you to use either GHC or Hugs.  To get GHC, just set the CPP variable
 202         __GLASGOW_HASKELL__
 203
 204 \begin{code}
 205
 206 #if defined(__GLASGOW_HASKELL__)
 207
 208 -- Glasgow Haskell
 209
 210 -- Disable ASSERT checks; they are expensive!
 211 #define LOCAL_ASSERT(x)
 212
 213 #define ILIT(x) (x#)
 214 #define IBOX(x) (I# (x))
 215 #define INT     Int#
 216 #define MINUS   -#
 217 #define NEGATE  negateInt#
 218 #define PLUS    +#
 219 #define GR      >#
 220 #define GREQ    >=#
 221 #define LT      <#
 222 #define DIV     `quotInt#`
 223
 224
 225 #define SHOW    Show
 226 #define MAXINT  maxBound
 227
 228 #else
 229
 230 -- Standard Haskell
 231
 232 #define LOCAL_ASSERT(x)
 233
 234 #define INT     Int
 235 #define IBOX(x) x
 236 #define MINUS   -
 237 #define NEGATE  negate
 238 #define PLUS    +
 239 #define GR      >
 240 #define GREQ    >=
 241 #define LT      <
 242 #define DIV     `quot`
 243 #define ILIT(x) x
 244
 245 #define SHOW    Show
 246 #define MAXINT  maxBound
 247
 248 #endif
 249
 250 \end{code}
 251
 252
 253 *********************************************************
 254 *                                                       *
 255 \subsection{The interface}
 256 *                                                       *
 257 *********************************************************
 258
 259 The primitive @Doc@ values
 260
 261 \begin{code}
 262 empty                     :: Doc
 263 isEmpty                   :: Doc    -> Bool
 264 text                      :: String -> Doc
 265 char                      :: Char -> Doc
 266
 267 semi, comma, colon, space, equals              :: Doc
 268 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
 269
 270 parens, brackets, braces  :: Doc -> Doc
 271 quotes, doubleQuotes      :: Doc -> Doc
 272
 273 int      :: Int -> Doc
 274 integer  :: Integer -> Doc
 275 float    :: Float -> Doc
 276 double   :: Double -> Doc
 277 rational :: Rational -> Doc
 278 \end{code}
 279
 280 Combining @Doc@ values
 281
 282 \begin{code}
 283 (<>)   :: Doc -> Doc -> Doc     -- Beside
 284 hcat   :: [Doc] -> Doc          -- List version of <>
 285 (<+>)  :: Doc -> Doc -> Doc     -- Beside, separated by space
 286 hsep   :: [Doc] -> Doc          -- List version of <+>
 287
 288 ($$)   :: Doc -> Doc -> Doc     -- Above; if there is no
 289                                 -- overlap it "dovetails" the two
 290 vcat   :: [Doc] -> Doc          -- List version of $$
 291
 292 cat    :: [Doc] -> Doc          -- Either hcat or vcat
 293 sep    :: [Doc] -> Doc          -- Either hsep or vcat
 294 fcat   :: [Doc] -> Doc          -- ``Paragraph fill'' version of cat
 295 fsep   :: [Doc] -> Doc          -- ``Paragraph fill'' version of sep
 296
 297 nest   :: Int -> Doc -> Doc     -- Nested
 298 \end{code}
 299
 300 GHC-specific ones.
 301
 302 \begin{code}
 303 hang :: Doc -> Int -> Doc -> Doc
 304 punctuate :: Doc -> [Doc] -> [Doc]      -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
 305 \end{code}
 306
 307 Displaying @Doc@ values.
 308
 309 \begin{code}
 310 instance SHOW Doc where
 311   showsPrec prec doc cont = showDoc doc cont
 312
 313 render     :: Doc -> String             -- Uses default style
 314 fullRender :: Mode
 315            -> Int                       -- Line length
 316            -> Float                     -- Ribbons per line
 317            -> (TextDetails -> a -> a)   -- What to do with text
 318            -> a                         -- What to do at the end
 319            -> Doc
 320            -> a                         -- Result
 321
 322 {-      When we start using 1.3
 323 renderStyle  :: Style -> Doc -> String
 324 data Style = Style { lineLength     :: Int,     -- In chars
 325                      ribbonsPerLine :: Float,   -- Ratio of ribbon length to line length
 326                      mode :: Mode
 327              }
 328 style :: Style          -- The default style
 329 style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
 330 -}
 331
 332 data Mode = PageMode            -- Normal
 333           | ZigZagMode          -- With zig-zag cuts
 334           | LeftMode            -- No indentation, infinitely long lines
 335           | OneLineMode         -- All on one line
 336
 337 \end{code}
 338
 339
 340 *********************************************************
 341 *                                                       *
 342 \subsection{The @Doc@ calculus}
 343 *                                                       *
 344 *********************************************************
 345
 346 The @Doc@ combinators satisfy the following laws:
 347 \begin{verbatim}
 348 Laws for $$
 349 ~~~~~~~~~~~
 350 <a1>    (x $$ y) $$ z   = x $$ (y $$ z)
 351 <a2>    empty $$ x      = x
 352 <a3>    x $$ empty      = x
 353
 354         ...ditto $+$...
 355
 356 Laws for <>
 357 ~~~~~~~~~~~
 358 <b1>    (x <> y) <> z   = x <> (y <> z)
 359 <b2>    empty <> x      = empty
 360 <b3>    x <> empty      = x
 361
 362         ...ditto <+>...
 363
 364 Laws for text
 365 ~~~~~~~~~~~~~
 366 <t1>    text s <> text t        = text (s++t)
 367 <t2>    text "" <> x            = x, if x non-empty
 368
 369 Laws for nest
 370 ~~~~~~~~~~~~~
 371 <n1>    nest 0 x                = x
 372 <n2>    nest k (nest k' x)      = nest (k+k') x
 373 <n3>    nest k (x <> y)         = nest k z <> nest k y
 374 <n4>    nest k (x $$ y)         = nest k x $$ nest k y
 375 <n5>    nest k empty            = empty
 376 <n6>    x <> nest k y           = x <> y, if x non-empty
 377
 378 ** Note the side condition on <n6>!  It is this that
 379 ** makes it OK for empty to be a left unit for <>.
 380
 381 Miscellaneous
 382 ~~~~~~~~~~~~~
 383 <m1>    (text s <> x) $$ y = text s <> ((text "" <> x)) $$
 384                                          nest (-length s) y)
 385
 386 <m2>    (x $$ y) <> z = x $$ (y <> z)
 387         if y non-empty
 388
 389
 390 Laws for list versions
 391 ~~~~~~~~~~~~~~~~~~~~~~
 392 <l1>    sep (ps++[empty]++qs)   = sep (ps ++ qs)
 393         ...ditto hsep, hcat, vcat, fill...
 394
 395 <l2>    nest k (sep ps) = sep (map (nest k) ps)
 396         ...ditto hsep, hcat, vcat, fill...
 397
 398 Laws for oneLiner
 399 ~~~~~~~~~~~~~~~~~
 400 <o1>    oneLiner (nest k p) = nest k (oneLiner p)
 401 <o2>    oneLiner (x <> y)   = oneLiner x <> oneLiner y
 402 \end{verbatim}
 403
 404
 405 You might think that the following verion of <m1> would
 406 be neater:
 407 \begin{verbatim}
 408 <3 NO>  (text s <> x) $$ y = text s <> ((empty <> x)) $$
 409                                          nest (-length s) y)
 410 \end{verbatim}
 411 But it doesn't work, for if x=empty, we would have
 412 \begin{verbatim}
 413         text s $$ y = text s <> (empty $$ nest (-length s) y)
 414                     = text s <> nest (-length s) y
 415 \end{verbatim}
 416
 417
 418
 419 *********************************************************
 420 *                                                       *
 421 \subsection{Simple derived definitions}
 422 *                                                       *
 423 *********************************************************
 424
 425 \begin{code}
 426 semi  = char ';'
 427 colon = char ':'
 428 comma = char ','
 429 space = char ' '
 430 equals = char '='
 431 lparen = char '('
 432 rparen = char ')'
 433 lbrack = char '['
 434 rbrack = char ']'
 435 lbrace = char '{'
 436 rbrace = char '}'
 437
 438 int      n = text (show n)
 439 integer  n = text (show n)
 440 float    n = text (show n)
 441 double   n = text (show n)
 442 rational n = text (show (fromRat n))
 443 --rational n = text (show (fromRationalX n)) -- _showRational 30 n)
 444
 445 quotes p        = char '`' <> p <> char '\''
 446 doubleQuotes p  = char '"' <> p <> char '"'
 447 parens p        = char '(' <> p <> char ')'
 448 brackets p      = char '[' <> p <> char ']'
 449 braces p        = char '{' <> p <> char '}'
 450
 451
 452 hcat = foldr (<>)  empty
 453 hsep = foldr (<+>) empty
 454 vcat = foldr ($$)  empty
 455
 456 hang d1 n d2 = sep [d1, nest n d2]
 457
 458 punctuate p []     = []
 459 punctuate p (d:ds) = go d ds
 460                    where
 461                      go d [] = [d]
 462                      go d (e:es) = (d <> p) : go e es
 463 \end{code}
 464
 465
 466 *********************************************************
 467 *                                                       *
 468 \subsection{The @Doc@ data type}
 469 *                                                       *
 470 *********************************************************
 471
 472 A @Doc@ represents a {\em set} of layouts.  A @Doc@ with
 473 no occurrences of @Union@ or @NoDoc@ represents just one layout.
 474 \begin{code}
 475 data Doc
 476  = Empty                                -- empty
 477  | NilAbove Doc                         -- text "" $$ x
 478  | TextBeside TextDetails INT Doc       -- text s <> x
 479  | Nest INT Doc                         -- nest k x
 480  | Union Doc Doc                        -- ul `union` ur
 481  | NoDoc                                -- The empty set of documents
 482  | Beside Doc Bool Doc                  -- True <=> space between
 483  | Above  Doc Bool Doc                  -- True <=> never overlap
 484
 485 type RDoc = Doc         -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
 486
 487
 488 reduceDoc :: Doc -> RDoc
 489 reduceDoc (Beside p g q) = beside p g (reduceDoc q)
 490 reduceDoc (Above  p g q) = above  p g (reduceDoc q)
 491 reduceDoc p              = p
 492
 493
 494 data TextDetails = Chr  Char
 495                  | Str  String
 496                  | PStr FAST_STRING
 497 space_text = Chr ' '
 498 nl_text    = Chr '\n'
 499 \end{code}
 500
 501 Here are the invariants:
 502 \begin{itemize}
 503 \item
 504 The argument of @NilAbove@ is never @Empty@. Therefore
 505 a @NilAbove@ occupies at least two lines.
 506
 507 \item
 508 The arugment of @TextBeside@ is never @Nest@.
 509
 510 \item
 511 The layouts of the two arguments of @Union@ both flatten to the same string.
 512
 513 \item
 514 The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
 515
 516 \item
 517 The right argument of a union cannot be equivalent to the empty set (@NoDoc@).
 518 If the left argument of a union is equivalent to the empty set (@NoDoc@),
 519 then the @NoDoc@ appears in the first line.
 520
 521 \item
 522 An empty document is always represented by @Empty@.
 523 It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.
 524
 525 \item
 526 The first line of every layout in the left argument of @Union@
 527 is longer than the first line of any layout in the right argument.
 528 (1) ensures that the left argument has a first line.  In view of (3),
 529 this invariant means that the right argument must have at least two
 530 lines.
 531 \end{itemize}
 532
 533 \begin{code}
 534         -- Arg of a NilAbove is always an RDoc
 535 nilAbove_ p = LOCAL_ASSERT( ok p ) NilAbove p
 536             where
 537               ok Empty = False
 538               ok other = True
 539
 540         -- Arg of a TextBeside is always an RDoc
 541 textBeside_ s sl p = TextBeside s sl (LOCAL_ASSERT( ok p ) p)
 542                    where
 543                      ok (Nest _ _) = False
 544                      ok other      = True
 545
 546         -- Arg of Nest is always an RDoc
 547 nest_ k p = Nest k (LOCAL_ASSERT( ok p ) p)
 548           where
 549             ok Empty = False
 550             ok other = True
 551
 552         -- Args of union are always RDocs
 553 union_ p q = Union (LOCAL_ASSERT( ok p ) p) (LOCAL_ASSERT( ok q ) q)
 554            where
 555              ok (TextBeside _ _ _) = True
 556              ok (NilAbove _)       = True
 557              ok (Union _ _)        = True
 558              ok other              = False
 559 \end{code}
 560
 561
 562 Notice the difference between
 563         * NoDoc (no documents)
 564         * Empty (one empty document; no height and no width)
 565         * text "" (a document containing the empty string;
 566                    one line high, but has no width)
 567
 568
 569
 570 *********************************************************
 571 *                                                       *
 572 \subsection{@empty@, @text@, @nest@, @union@}
 573 *                                                       *
 574 *********************************************************
 575
 576 \begin{code}
 577 empty = Empty
 578
 579 isEmpty Empty = True
 580 isEmpty _     = False
 581
 582 char  c = textBeside_ (Chr c) 1# Empty
 583 text  s = case length   s of {IBOX(sl) -> textBeside_ (Str s)  sl Empty}
 584 ptext s = case _LENGTH_ s of {IBOX(sl) -> textBeside_ (PStr s) sl Empty}
 585
 586 nest IBOX(k)  p = mkNest k (reduceDoc p)        -- Externally callable version
 587
 588 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
 589 mkNest k       (Nest k1 p) = mkNest (k PLUS k1) p
 590 mkNest k       NoDoc       = NoDoc
 591 mkNest k       Empty       = Empty
 592 mkNest ILIT(0) p           = p                  -- Worth a try!
 593 mkNest k       p           = nest_ k p
 594
 595 -- mkUnion checks for an empty document
 596 mkUnion Empty q = Empty
 597 mkUnion p q     = p `union_` q
 598 \end{code}
 599
 600 *********************************************************
 601 *                                                       *
 602 \subsection{Vertical composition @$$@}
 603 *                                                       *
 604 *********************************************************
 605
 606
 607 \begin{code}
 608 p $$  q = Above p False q
 609 p $+$ q = Above p True q
 610
 611 above :: Doc -> Bool -> RDoc -> RDoc
 612 above (Above p g1 q1)  g2 q2 = above p g1 (above q1 g2 q2)
 613 above p@(Beside _ _ _) g  q  = aboveNest (reduceDoc p) g ILIT(0) (reduceDoc q)
 614 above p g q                  = aboveNest p             g ILIT(0) (reduceDoc q)
 615
 616 aboveNest :: RDoc -> Bool -> INT -> RDoc -> RDoc
 617 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
 618
 619 aboveNest NoDoc               g k q = NoDoc
 620 aboveNest (p1 `Union` p2)     g k q = aboveNest p1 g k q `union_`
 621                                       aboveNest p2 g k q
 622
 623 aboveNest Empty               g k q = mkNest k q
 624 aboveNest (Nest k1 p)         g k q = nest_ k1 (aboveNest p g (k MINUS k1) q)
 625                                   -- p can't be Empty, so no need for mkNest
 626
 627 aboveNest (NilAbove p)        g k q = nilAbove_ (aboveNest p g k q)
 628 aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
 629                                     where
 630                                       k1   = k MINUS sl
 631                                       rest = case p of
 632                                                 Empty -> nilAboveNest g k1 q
 633                                                 other -> aboveNest  p g k1 q
 634 \end{code}
 635
 636 \begin{code}
 637 nilAboveNest :: Bool -> INT -> RDoc -> RDoc
 638 -- Specification: text s <> nilaboveNest g k q
 639 --              = text s <> (text "" $g$ nest k q)
 640
 641 nilAboveNest g k Empty       = Empty    -- Here's why the "text s <>" is in the spec!
 642 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k PLUS k1) q
 643
 644 nilAboveNest g k q           | (not g) && (k GR ILIT(0))        -- No newline if no overlap
 645                              = textBeside_ (Str (spaces k)) k q
 646                              | otherwise                        -- Put them really above
 647                              = nilAbove_ (mkNest k q)
 648 \end{code}
 649
 650
 651 *********************************************************
 652 *                                                       *
 653 \subsection{Horizontal composition @<>@}
 654 *                                                       *
 655 *********************************************************
 656
 657 \begin{code}
 658 p <>  q = Beside p False q
 659 p <+> q = Beside p True  q
 660
 661 beside :: Doc -> Bool -> RDoc -> RDoc
 662 -- Specification: beside g p q = p <g> q
 663
 664 beside NoDoc               g q   = NoDoc
 665 beside (p1 `Union` p2)     g q   = (beside p1 g q) `union_` (beside p2 g q)
 666 beside Empty               g q   = q
 667 beside (Nest k p)          g q   = nest_ k (beside p g q)       -- p non-empty
 668 beside p@(Beside p1 g1 q1) g2 q2
 669            {- (A `op1` B) `op2` C == A `op1` (B `op2` C)  iff op1 == op2
 670                                                  [ && (op1 == <> || op1 == <+>) ] -}
 671          | g1 == g2              = beside p1 g1 (beside q1 g2 q2)
 672          | otherwise             = beside (reduceDoc p) g2 q2
 673 beside p@(Above _ _ _)     g q   = beside (reduceDoc p) g q
 674 beside (NilAbove p)        g q   = nilAbove_ (beside p g q)
 675 beside (TextBeside s sl p) g q   = textBeside_ s sl rest
 676                                where
 677                                   rest = case p of
 678                                            Empty -> nilBeside g q
 679                                            other -> beside p g q
 680 \end{code}
 681
 682 \begin{code}
 683 nilBeside :: Bool -> RDoc -> RDoc
 684 -- Specification: text "" <> nilBeside g p
 685 --              = text "" <g> p
 686
 687 nilBeside g Empty      = Empty  -- Hence the text "" in the spec
 688 nilBeside g (Nest _ p) = nilBeside g p
 689 nilBeside g p          | g         = textBeside_ space_text ILIT(1) p
 690                        | otherwise = p
 691 \end{code}
 692
 693 *********************************************************
 694 *                                                       *
 695 \subsection{Separate, @sep@, Hughes version}
 696 *                                                       *
 697 *********************************************************
 698
 699 \begin{code}
 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) ILIT(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 NoDoc               k ys = NoDoc
 717 sep1 g (p `Union` q)       k ys = sep1 g p k ys
 718                                   `union_`
 719                                   (aboveNest q False k (reduceDoc (vcat ys)))
 720
 721 sep1 g Empty               k ys = mkNest k (sepX g ys)
 722 sep1 g (Nest n p)          k ys = nest_ n (sep1 g p (k MINUS n) ys)
 723
 724 sep1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
 725 sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k MINUS sl) ys)
 726
 727 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
 728 -- Called when we have already found some text in the first item
 729 -- We have to eat up nests
 730
 731 sepNB g (Nest _ p)  k ys  = sepNB g p k ys
 732
 733 sepNB g Empty k ys        = oneLiner (nilBeside g (reduceDoc rest))
 734                                 `mkUnion`
 735                             nilAboveNest False k (reduceDoc (vcat ys))
 736                           where
 737                             rest | g         = hsep ys
 738                                  | otherwise = hcat ys
 739
 740 sepNB g p k ys            = sep1 g p k ys
 741 \end{code}
 742
 743 *********************************************************
 744 *                                                       *
 745 \subsection{@fill@}
 746 *                                                       *
 747 *********************************************************
 748
 749 \begin{code}
 750 fsep = fill True
 751 fcat = fill False
 752
 753 -- Specification:
 754 --   fill []  = empty
 755 --   fill [p] = p
 756 --   fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
 757 --                                          (fill (oneLiner p2 : ps))
 758 --                     `union`
 759 --                      p1 $$ fill ps
 760
 761 fill g []     = empty
 762 fill g (p:ps) = fill1 g (reduceDoc p) ILIT(0) ps
 763
 764
 765 fill1 :: Bool -> RDoc -> INT -> [Doc] -> Doc
 766 fill1 g NoDoc               k ys = NoDoc
 767 fill1 g (p `Union` q)       k ys = fill1 g p k ys
 768                                    `union_`
 769                                    (aboveNest q False k (fill g ys))
 770
 771 fill1 g Empty               k ys = mkNest k (fill g ys)
 772 fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k MINUS n) ys)
 773
 774 fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fill g ys))
 775 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k MINUS sl) ys)
 776
 777 fillNB g (Nest _ p)  k ys  = fillNB g p k ys
 778 fillNB g Empty k []        = Empty
 779 fillNB g Empty k (y:ys)    = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
 780                              `mkUnion`
 781                              nilAboveNest False k (fill g (y:ys))
 782                            where
 783                              k1 | g         = k MINUS ILIT(1)
 784                                 | otherwise = k
 785
 786 fillNB g p k ys            = fill1 g p k ys
 787 \end{code}
 788
 789
 790 *********************************************************
 791 *                                                       *
 792 \subsection{Selecting the best layout}
 793 *                                                       *
 794 *********************************************************
 795
 796 \begin{code}
 797 best :: Int             -- Line length
 798      -> Int             -- Ribbon length
 799      -> RDoc
 800      -> RDoc            -- No unions in here!
 801
 802 best IBOX(w) IBOX(r) p
 803   = get w p
 804   where
 805     get :: INT          -- (Remaining) width of line
 806         -> Doc -> Doc
 807     get w Empty               = Empty
 808     get w NoDoc               = NoDoc
 809     get w (NilAbove p)        = nilAbove_ (get w p)
 810     get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
 811     get w (Nest k p)          = nest_ k (get (w MINUS k) p)
 812     get w (p `Union` q)       = nicest w r (get w p) (get w q)
 813
 814     get1 :: INT         -- (Remaining) width of line
 815          -> INT         -- Amount of first line already eaten up
 816          -> Doc         -- This is an argument to TextBeside => eat Nests
 817          -> Doc         -- No unions in here!
 818
 819     get1 w sl Empty               = Empty
 820     get1 w sl NoDoc               = NoDoc
 821     get1 w sl (NilAbove p)        = nilAbove_ (get (w MINUS sl) p)
 822     get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl PLUS tl) p)
 823     get1 w sl (Nest k p)          = get1 w sl p
 824     get1 w sl (p `Union` q)       = nicest1 w r sl (get1 w sl p)
 825                                                    (get1 w sl q)
 826
 827 nicest w r p q = nicest1 w r ILIT(0) p q
 828 nicest1 w r sl p q | fits ((w `minn` r) MINUS sl) p = p
 829                    | otherwise                   = q
 830
 831 fits :: INT     -- Space available
 832      -> Doc
 833      -> Bool    -- True if *first line* of Doc fits in space available
 834
 835 fits n p    | n LT ILIT(0) = False
 836 fits n NoDoc               = False
 837 fits n Empty               = True
 838 fits n (NilAbove _)        = True
 839 fits n (TextBeside _ sl p) = fits (n MINUS sl) p
 840
 841 minn x y | x LT y    = x
 842          | otherwise = y
 843 \end{code}
 844
 845 @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
 846 @first@ returns its first argument if it is non-empty, otherwise its second.
 847
 848 \begin{code}
 849 first p q | nonEmptySet p = p
 850           | otherwise     = q
 851
 852 nonEmptySet NoDoc              = False
 853 nonEmptySet (p `Union` q)      = True
 854 nonEmptySet Empty              = True
 855 nonEmptySet (NilAbove p)       = True           -- NoDoc always in first line
 856 nonEmptySet (TextBeside _ _ p) = nonEmptySet p
 857 nonEmptySet (Nest _ p)         = nonEmptySet p
 858 \end{code}
 859
 860 @oneLiner@ returns the one-line members of the given set of @Doc@s.
 861
 862 \begin{code}
 863 oneLiner :: Doc -> Doc
 864 oneLiner NoDoc               = NoDoc
 865 oneLiner Empty               = Empty
 866 oneLiner (NilAbove p)        = NoDoc
 867 oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
 868 oneLiner (Nest k p)          = nest_ k (oneLiner p)
 869 oneLiner (p `Union` q)       = oneLiner p
 870 \end{code}
 871
 872
 873
 874 *********************************************************
 875 *                                                       *
 876 \subsection{Displaying the best layout}
 877 *                                                       *
 878 *********************************************************
 879
 880
 881 \begin{code}
 882 {-
 883 renderStyle Style{mode, lineLength, ribbonsPerLine} doc
 884   = fullRender mode lineLength ribbonsPerLine doc ""
 885 -}
 886
 887 render doc       = showDoc doc ""
 888 showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc
 889
 890 string_txt (Chr c)   s  = c:s
 891 string_txt (Str s1)  s2 = s1 ++ s2
 892 string_txt (PStr s1) s2 = _UNPK_ s1 ++ s2
 893 \end{code}
 894
 895 \begin{code}
 896
 897 fullRender OneLineMode _ _ txt end doc
 898   = lay (reduceDoc doc)
 899   where
 900     lay NoDoc               = cant_fail
 901     lay (Union p q)         = (lay q)                   -- Second arg can't be NoDoc
 902     lay (Nest k p)          = lay p
 903     lay Empty               = end
 904     lay (NilAbove p)        = space_text `txt` lay p    -- NoDoc always on first line
 905     lay (TextBeside s sl p) = s `txt` lay p
 906
 907 fullRender LeftMode    _ _ txt end doc
 908   = lay (reduceDoc doc)
 909   where
 910     lay NoDoc                   = cant_fail
 911     lay (Union p q)             = lay (first p q)
 912     lay (Nest k p)              = lay p
 913     lay Empty                   = end
 914     lay (NilAbove p)            = nl_text `txt` lay p   -- NoDoc always on first line
 915     lay (TextBeside s sl p)     = s `txt` lay p
 916
 917 fullRender mode line_length ribbons_per_line txt end doc
 918   = display mode line_length ribbon_length txt end best_doc
 919   where
 920     best_doc = best hacked_line_length ribbon_length (reduceDoc doc)
 921
 922     hacked_line_length, ribbon_length :: Int
 923     ribbon_length = round (fromIntegral line_length / ribbons_per_line)
 924     hacked_line_length = case mode of { ZigZagMode -> MAXINT; other -> line_length }
 925
 926 display mode IBOX(page_width) IBOX(ribbon_width) txt end doc
 927   = case page_width MINUS ribbon_width of { gap_width ->
 928     case gap_width DIV ILIT(2) of { shift ->
 929     let
 930         lay k (Nest k1 p)  = lay (k PLUS k1) p
 931         lay k Empty        = end
 932
 933         lay k (NilAbove p) = nl_text `txt` lay k p
 934
 935         lay k (TextBeside s sl p)
 936             = case mode of
 937                     ZigZagMode |  k GREQ gap_width
 938                                -> nl_text `txt` (
 939                                   Str (multi_ch shift '/') `txt` (
 940                                   nl_text `txt` (
 941                                   lay1 (k MINUS shift) s sl p)))
 942
 943                                |  k LT ILIT(0)
 944                                -> nl_text `txt` (
 945                                   Str (multi_ch shift '\\') `txt` (
 946                                   nl_text `txt` (
 947                                   lay1 (k PLUS shift) s sl p )))
 948
 949                     other -> lay1 k s sl p
 950
 951         lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k PLUS sl) p)
 952
 953         lay2 k (NilAbove p)        = nl_text `txt` lay k p
 954         lay2 k (TextBeside s sl p) = s `txt` (lay2 (k PLUS sl) p)
 955         lay2 k (Nest _ p)          = lay2 k p
 956         lay2 k Empty               = end
 957     in
 958     lay ILIT(0) doc
 959     }}
 960
 961 cant_fail = error "easy_display: NoDoc"
 962
 963 indent n | n GREQ ILIT(8) = '\t' : indent (n MINUS ILIT(8))
 964          | otherwise      = spaces n
 965
 966 multi_ch ILIT(0) ch = ""
 967 multi_ch n       ch = ch : multi_ch (n MINUS ILIT(1)) ch
 968
 969 spaces ILIT(0) = ""
 970 spaces n       = ' ' : spaces (n MINUS ILIT(1))
 971 \end{code}
 972
 973 \begin{code}
 974 pprCols = (100 :: Int) -- could make configurable
 975
 976 printDoc :: Mode -> Handle -> Doc -> IO ()
 977 printDoc mode hdl doc
 978   = fullRender mode pprCols 1.5 put done doc
 979   where
 980     put (Chr c)  next = hPutChar hdl c >> next
 981     put (Str s)  next = hPutStr  hdl s >> next
 982     put (PStr s) next = hPutFS   hdl s >> next
 983
 984     done = hPutChar hdl '\n'
 985 \end{code}