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