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