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 it 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, cparen,
 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 cparen True  = parens
 459 cparen False = id
 460
 461 hcat = foldr (<>)  empty
 462 hsep = foldr (<+>) empty
 463 vcat = foldr ($$)  empty
 464
 465 hang d1 n d2 = sep [d1, nest n d2]
 466
 467 punctuate p []     = []
 468 punctuate p (d:ds) = go d ds
 469                    where
 470                      go d [] = [d]
 471                      go d (e:es) = (d <> p) : go e es
 472 \end{code}
 473
 474
 475 *********************************************************
 476 *                                                       *
 477 \subsection{The @Doc@ data type}
 478 *                                                       *
 479 *********************************************************
 480
 481 A @Doc@ represents a {\em set} of layouts.  A @Doc@ with
 482 no occurrences of @Union@ or @NoDoc@ represents just one layout.
 483 \begin{code}
 484 data Doc
 485  = Empty                                -- empty
 486  | NilAbove Doc                         -- text "" $$ x
 487  | TextBeside !TextDetails INT Doc       -- text s <> x
 488  | Nest INT Doc                         -- nest k x
 489  | Union Doc Doc                        -- ul `union` ur
 490  | NoDoc                                -- The empty set of documents
 491  | Beside Doc Bool Doc                  -- True <=> space between
 492  | Above  Doc Bool Doc                  -- True <=> never overlap
 493
 494 type RDoc = Doc         -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
 495
 496
 497 reduceDoc :: Doc -> RDoc
 498 reduceDoc (Beside p g q) = beside p g (reduceDoc q)
 499 reduceDoc (Above  p g q) = above  p g (reduceDoc q)
 500 reduceDoc p              = p
 501
 502
 503 data TextDetails = Chr  {-#UNPACK#-}!Char
 504                  | Str  String
 505                  | PStr FastString      -- a hashed string
 506                  | LStr Addr# Int#      -- a '\0'-terminated array of bytes
 507
 508 space_text = Chr ' '
 509 nl_text    = Chr '\n'
 510 \end{code}
 511
 512 Here are the invariants:
 513 \begin{itemize}
 514 \item
 515 The argument of @NilAbove@ is never @Empty@. Therefore
 516 a @NilAbove@ occupies at least two lines.
 517
 518 \item
 519 The arugment of @TextBeside@ is never @Nest@.
 520
 521 \item
 522 The layouts of the two arguments of @Union@ both flatten to the same string.
 523
 524 \item
 525 The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
 526
 527 \item
 528 The right argument of a union cannot be equivalent to the empty set (@NoDoc@).
 529 If the left argument of a union is equivalent to the empty set (@NoDoc@),
 530 then the @NoDoc@ appears in the first line.
 531
 532 \item
 533 An empty document is always represented by @Empty@.
 534 It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.
 535
 536 \item
 537 The first line of every layout in the left argument of @Union@
 538 is longer than the first line of any layout in the right argument.
 539 (1) ensures that the left argument has a first line.  In view of (3),
 540 this invariant means that the right argument must have at least two
 541 lines.
 542 \end{itemize}
 543
 544 \begin{code}
 545         -- Arg of a NilAbove is always an RDoc
 546 nilAbove_ p = LOCAL_ASSERT( ok p ) NilAbove p
 547             where
 548               ok Empty = False
 549               ok other = True
 550
 551         -- Arg of a TextBeside is always an RDoc
 552 textBeside_ s sl p = TextBeside s sl (LOCAL_ASSERT( ok p ) p)
 553                    where
 554                      ok (Nest _ _) = False
 555                      ok other      = True
 556
 557         -- Arg of Nest is always an RDoc
 558 nest_ k p = Nest k (LOCAL_ASSERT( ok p ) p)
 559           where
 560             ok Empty = False
 561             ok other = True
 562
 563         -- Args of union are always RDocs
 564 union_ p q = Union (LOCAL_ASSERT( ok p ) p) (LOCAL_ASSERT( ok q ) q)
 565            where
 566              ok (TextBeside _ _ _) = True
 567              ok (NilAbove _)       = True
 568              ok (Union _ _)        = True
 569              ok other              = False
 570 \end{code}
 571
 572
 573 Notice the difference between
 574         * NoDoc (no documents)
 575         * Empty (one empty document; no height and no width)
 576         * text "" (a document containing the empty string;
 577                    one line high, but has no width)
 578
 579
 580
 581 *********************************************************
 582 *                                                       *
 583 \subsection{@empty@, @text@, @nest@, @union@}
 584 *                                                       *
 585 *********************************************************
 586
 587 \begin{code}
 588 empty = Empty
 589
 590 isEmpty Empty = True
 591 isEmpty _     = False
 592
 593 char  c = textBeside_ (Chr c) 1# Empty
 594 text  s = case length   s of {IBOX(sl) -> textBeside_ (Str s)  sl Empty}
 595 ftext s = case lengthFS s of {IBOX(sl) -> textBeside_ (PStr s) sl Empty}
 596 ptext (Ptr s) = case strLength (Ptr s) of {IBOX(sl) -> textBeside_ (LStr s sl) sl Empty}
 597
 598 -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
 599 -- intermediate packing/unpacking of the string.
 600 {-# RULES
 601   "text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
 602  #-}
 603
 604 nest IBOX(k)  p = mkNest k (reduceDoc p)        -- Externally callable version
 605
 606 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
 607 mkNest k       (Nest k1 p) = mkNest (k PLUS k1) p
 608 mkNest k       NoDoc       = NoDoc
 609 mkNest k       Empty       = Empty
 610 mkNest ILIT(0) p           = p                  -- Worth a try!
 611 mkNest k       p           = nest_ k p
 612
 613 -- mkUnion checks for an empty document
 614 mkUnion Empty q = Empty
 615 mkUnion p q     = p `union_` q
 616 \end{code}
 617
 618 *********************************************************
 619 *                                                       *
 620 \subsection{Vertical composition @$$@}
 621 *                                                       *
 622 *********************************************************
 623
 624
 625 \begin{code}
 626 p $$  q = Above p False q
 627 p $+$ q = Above p True q
 628
 629 above :: Doc -> Bool -> RDoc -> RDoc
 630 above (Above p g1 q1)  g2 q2 = above p g1 (above q1 g2 q2)
 631 above p@(Beside _ _ _) g  q  = aboveNest (reduceDoc p) g ILIT(0) (reduceDoc q)
 632 above p g q                  = aboveNest p             g ILIT(0) (reduceDoc q)
 633
 634 aboveNest :: RDoc -> Bool -> INT -> RDoc -> RDoc
 635 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
 636
 637 aboveNest NoDoc               g k q = NoDoc
 638 aboveNest (p1 `Union` p2)     g k q = aboveNest p1 g k q `union_`
 639                                       aboveNest p2 g k q
 640
 641 aboveNest Empty               g k q = mkNest k q
 642 aboveNest (Nest k1 p)         g k q = nest_ k1 (aboveNest p g (k MINUS k1) q)
 643                                   -- p can't be Empty, so no need for mkNest
 644
 645 aboveNest (NilAbove p)        g k q = nilAbove_ (aboveNest p g k q)
 646 aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
 647                                     where
 648                                       k1   = k MINUS sl
 649                                       rest = case p of
 650                                                 Empty -> nilAboveNest g k1 q
 651                                                 other -> aboveNest  p g k1 q
 652 \end{code}
 653
 654 \begin{code}
 655 nilAboveNest :: Bool -> INT -> RDoc -> RDoc
 656 -- Specification: text s <> nilaboveNest g k q
 657 --              = text s <> (text "" $g$ nest k q)
 658
 659 nilAboveNest g k Empty       = Empty    -- Here's why the "text s <>" is in the spec!
 660 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k PLUS k1) q
 661
 662 nilAboveNest g k q           | (not g) && (k GR ILIT(0))        -- No newline if no overlap
 663                              = textBeside_ (Str (spaces k)) k q
 664                              | otherwise                        -- Put them really above
 665                              = nilAbove_ (mkNest k q)
 666 \end{code}
 667
 668
 669 *********************************************************
 670 *                                                       *
 671 \subsection{Horizontal composition @<>@}
 672 *                                                       *
 673 *********************************************************
 674
 675 \begin{code}
 676 p <>  q = Beside p False q
 677 p <+> q = Beside p True  q
 678
 679 beside :: Doc -> Bool -> RDoc -> RDoc
 680 -- Specification: beside g p q = p <g> q
 681
 682 beside NoDoc               g q   = NoDoc
 683 beside (p1 `Union` p2)     g q   = (beside p1 g q) `union_` (beside p2 g q)
 684 beside Empty               g q   = q
 685 beside (Nest k p)          g q   = nest_ k $! beside p g q       -- p non-empty
 686 beside p@(Beside p1 g1 q1) g2 q2
 687            {- (A `op1` B) `op2` C == A `op1` (B `op2` C)  iff op1 == op2
 688                                                  [ && (op1 == <> || op1 == <+>) ] -}
 689          | g1 == g2              = beside p1 g1 $! beside q1 g2 q2
 690          | otherwise             = beside (reduceDoc p) g2 q2
 691 beside p@(Above _ _ _)     g q   = let d = reduceDoc p in d `seq` beside d g q
 692 beside (NilAbove p)        g q   = nilAbove_ $! beside p g q
 693 beside (TextBeside s sl p) g q   = textBeside_ s sl $! rest
 694                                where
 695                                   rest = case p of
 696                                            Empty -> nilBeside g q
 697                                            other -> beside p g q
 698 \end{code}
 699
 700 \begin{code}
 701 nilBeside :: Bool -> RDoc -> RDoc
 702 -- Specification: text "" <> nilBeside g p
 703 --              = text "" <g> p
 704
 705 nilBeside g Empty      = Empty  -- Hence the text "" in the spec
 706 nilBeside g (Nest _ p) = nilBeside g p
 707 nilBeside g p          | g         = textBeside_ space_text ILIT(1) p
 708                        | otherwise = p
 709 \end{code}
 710
 711 *********************************************************
 712 *                                                       *
 713 \subsection{Separate, @sep@, Hughes version}
 714 *                                                       *
 715 *********************************************************
 716
 717 \begin{code}
 718 -- Specification: sep ps  = oneLiner (hsep ps)
 719 --                         `union`
 720 --                          vcat ps
 721
 722 sep = sepX True         -- Separate with spaces
 723 cat = sepX False        -- Don't
 724
 725 sepX x []     = empty
 726 sepX x (p:ps) = sep1 x (reduceDoc p) ILIT(0) ps
 727
 728
 729 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
 730 --                            = oneLiner (x <g> nest k (hsep ys))
 731 --                              `union` x $$ nest k (vcat ys)
 732
 733 sep1 :: Bool -> RDoc -> INT -> [Doc] -> RDoc
 734 sep1 g NoDoc               k ys = NoDoc
 735 sep1 g (p `Union` q)       k ys = sep1 g p k ys
 736                                   `union_`
 737                                   (aboveNest q False k (reduceDoc (vcat ys)))
 738
 739 sep1 g Empty               k ys = mkNest k (sepX g ys)
 740 sep1 g (Nest n p)          k ys = nest_ n (sep1 g p (k MINUS n) ys)
 741
 742 sep1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
 743 sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k MINUS sl) ys)
 744
 745 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
 746 -- Called when we have already found some text in the first item
 747 -- We have to eat up nests
 748
 749 sepNB g (Nest _ p)  k ys  = sepNB g p k ys
 750
 751 sepNB g Empty k ys        = oneLiner (nilBeside g (reduceDoc rest))
 752                                 `mkUnion`
 753                             nilAboveNest False k (reduceDoc (vcat ys))
 754                           where
 755                             rest | g         = hsep ys
 756                                  | otherwise = hcat ys
 757
 758 sepNB g p k ys            = sep1 g p k ys
 759 \end{code}
 760
 761 *********************************************************
 762 *                                                       *
 763 \subsection{@fill@}
 764 *                                                       *
 765 *********************************************************
 766
 767 \begin{code}
 768 fsep = fill True
 769 fcat = fill False
 770
 771 -- Specification:
 772 --   fill []  = empty
 773 --   fill [p] = p
 774 --   fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
 775 --                                          (fill (oneLiner p2 : ps))
 776 --                     `union`
 777 --                      p1 $$ fill ps
 778
 779 fill g []     = empty
 780 fill g (p:ps) = fill1 g (reduceDoc p) ILIT(0) ps
 781
 782
 783 fill1 :: Bool -> RDoc -> INT -> [Doc] -> Doc
 784 fill1 g NoDoc               k ys = NoDoc
 785 fill1 g (p `Union` q)       k ys = fill1 g p k ys
 786                                    `union_`
 787                                    (aboveNest q False k (fill g ys))
 788
 789 fill1 g Empty               k ys = mkNest k (fill g ys)
 790 fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k MINUS n) ys)
 791
 792 fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fill g ys))
 793 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k MINUS sl) ys)
 794
 795 fillNB g (Nest _ p)  k ys  = fillNB g p k ys
 796 fillNB g Empty k []        = Empty
 797 fillNB g Empty k (y:ys)    = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
 798                              `mkUnion`
 799                              nilAboveNest False k (fill g (y:ys))
 800                            where
 801                              k1 | g         = k MINUS ILIT(1)
 802                                 | otherwise = k
 803
 804 fillNB g p k ys            = fill1 g p k ys
 805 \end{code}
 806
 807
 808 *********************************************************
 809 *                                                       *
 810 \subsection{Selecting the best layout}
 811 *                                                       *
 812 *********************************************************
 813
 814 \begin{code}
 815 best :: Int             -- Line length
 816      -> Int             -- Ribbon length
 817      -> RDoc
 818      -> RDoc            -- No unions in here!
 819
 820 best IBOX(w) IBOX(r) p
 821   = get w p
 822   where
 823     get :: INT          -- (Remaining) width of line
 824         -> Doc -> Doc
 825     get w Empty               = Empty
 826     get w NoDoc               = NoDoc
 827     get w (NilAbove p)        = nilAbove_ (get w p)
 828     get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
 829     get w (Nest k p)          = nest_ k (get (w MINUS k) p)
 830     get w (p `Union` q)       = nicest w r (get w p) (get w q)
 831
 832     get1 :: INT         -- (Remaining) width of line
 833          -> INT         -- Amount of first line already eaten up
 834          -> Doc         -- This is an argument to TextBeside => eat Nests
 835          -> Doc         -- No unions in here!
 836
 837     get1 w sl Empty               = Empty
 838     get1 w sl NoDoc               = NoDoc
 839     get1 w sl (NilAbove p)        = nilAbove_ (get (w MINUS sl) p)
 840     get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl PLUS tl) p)
 841     get1 w sl (Nest k p)          = get1 w sl p
 842     get1 w sl (p `Union` q)       = nicest1 w r sl (get1 w sl p)
 843                                                    (get1 w sl q)
 844
 845 nicest w r p q = nicest1 w r ILIT(0) p q
 846 nicest1 w r sl p q | fits ((w `minn` r) MINUS sl) p = p
 847                    | otherwise                   = q
 848
 849 fits :: INT     -- Space available
 850      -> Doc
 851      -> Bool    -- True if *first line* of Doc fits in space available
 852
 853 fits n p    | n LT ILIT(0) = False
 854 fits n NoDoc               = False
 855 fits n Empty               = True
 856 fits n (NilAbove _)        = True
 857 fits n (TextBeside _ sl p) = fits (n MINUS sl) p
 858
 859 minn x y | x LT y    = x
 860          | otherwise = y
 861 \end{code}
 862
 863 @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
 864 @first@ returns its first argument if it is non-empty, otherwise its second.
 865
 866 \begin{code}
 867 first p q | nonEmptySet p = p
 868           | otherwise     = q
 869
 870 nonEmptySet NoDoc              = False
 871 nonEmptySet (p `Union` q)      = True
 872 nonEmptySet Empty              = True
 873 nonEmptySet (NilAbove p)       = True           -- NoDoc always in first line
 874 nonEmptySet (TextBeside _ _ p) = nonEmptySet p
 875 nonEmptySet (Nest _ p)         = nonEmptySet p
 876 \end{code}
 877
 878 @oneLiner@ returns the one-line members of the given set of @Doc@s.
 879
 880 \begin{code}
 881 oneLiner :: Doc -> Doc
 882 oneLiner NoDoc               = NoDoc
 883 oneLiner Empty               = Empty
 884 oneLiner (NilAbove p)        = NoDoc
 885 oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
 886 oneLiner (Nest k p)          = nest_ k (oneLiner p)
 887 oneLiner (p `Union` q)       = oneLiner p
 888 \end{code}
 889
 890
 891
 892 *********************************************************
 893 *                                                       *
 894 \subsection{Displaying the best layout}
 895 *                                                       *
 896 *********************************************************
 897
 898
 899 \begin{code}
 900 {-
 901 renderStyle Style{mode, lineLength, ribbonsPerLine} doc
 902   = fullRender mode lineLength ribbonsPerLine doc ""
 903 -}
 904
 905 render doc       = showDocWith PageMode doc
 906 showDoc doc rest = showDocWithAppend PageMode doc rest
 907
 908 showDocWithAppend :: Mode -> Doc -> String -> String
 909 showDocWithAppend mode doc rest = fullRender mode 100 1.5 string_txt rest doc
 910
 911 showDocWith :: Mode -> Doc -> String
 912 showDocWith mode doc = showDocWithAppend mode doc ""
 913
 914 string_txt (Chr c)   s  = c:s
 915 string_txt (Str s1)  s2 = s1 ++ s2
 916 string_txt (PStr s1) s2 = unpackFS s1 ++ s2
 917 string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
 918
 919 unpackLitString addr =
 920  unpack 0#
 921  where
 922     unpack nh
 923       | ch `eqChar#` '\0'# = []
 924       | otherwise   = C# ch : unpack (nh +# 1#)
 925       where
 926         ch = indexCharOffAddr# addr nh
 927 \end{code}
 928
 929 \begin{code}
 930
 931 fullRender OneLineMode _ _ txt end doc
 932   = lay (reduceDoc doc)
 933   where
 934     lay NoDoc               = cant_fail
 935     lay (Union p q)         = (lay q)                   -- Second arg can't be NoDoc
 936     lay (Nest k p)          = lay p
 937     lay Empty               = end
 938     lay (NilAbove p)        = space_text `txt` lay p    -- NoDoc always on first line
 939     lay (TextBeside s sl p) = s `txt` lay p
 940
 941 fullRender LeftMode    _ _ txt end doc
 942   = lay (reduceDoc doc)
 943   where
 944     lay NoDoc                   = cant_fail
 945     lay (Union p q)             = lay (first p q)
 946     lay (Nest k p)              = lay p
 947     lay Empty                   = end
 948     lay (NilAbove p)            = nl_text `txt` lay p   -- NoDoc always on first line
 949     lay (TextBeside s sl p)     = s `txt` lay p
 950
 951 fullRender mode line_length ribbons_per_line txt end doc
 952   = display mode line_length ribbon_length txt end best_doc
 953   where
 954     best_doc = best hacked_line_length ribbon_length (reduceDoc doc)
 955
 956     hacked_line_length, ribbon_length :: Int
 957     ribbon_length = round (fromIntegral line_length / ribbons_per_line)
 958     hacked_line_length = case mode of { ZigZagMode -> MAXINT; other -> line_length }
 959
 960 display mode IBOX(page_width) IBOX(ribbon_width) txt end doc
 961   = case page_width MINUS ribbon_width of { gap_width ->
 962     case gap_width DIV ILIT(2) of { shift ->
 963     let
 964         lay k (Nest k1 p)  = lay (k PLUS k1) p
 965         lay k Empty        = end
 966
 967         lay k (NilAbove p) = nl_text `txt` lay k p
 968
 969         lay k (TextBeside s sl p)
 970             = case mode of
 971                     ZigZagMode |  k GREQ gap_width
 972                                -> nl_text `txt` (
 973                                   Str (multi_ch shift '/') `txt` (
 974                                   nl_text `txt` (
 975                                   lay1 (k MINUS shift) s sl p)))
 976
 977                                |  k LT ILIT(0)
 978                                -> nl_text `txt` (
 979                                   Str (multi_ch shift '\\') `txt` (
 980                                   nl_text `txt` (
 981                                   lay1 (k PLUS shift) s sl p )))
 982
 983                     other -> lay1 k s sl p
 984
 985         lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k PLUS sl) p)
 986
 987         lay2 k (NilAbove p)        = nl_text `txt` lay k p
 988         lay2 k (TextBeside s sl p) = s `txt` (lay2 (k PLUS sl) p)
 989         lay2 k (Nest _ p)          = lay2 k p
 990         lay2 k Empty               = end
 991     in
 992     lay ILIT(0) doc
 993     }}
 994
 995 cant_fail = error "easy_display: NoDoc"
 996
 997 indent n | n GREQ ILIT(8) = '\t' : indent (n MINUS ILIT(8))
 998          | otherwise      = spaces n
 999
1000 multi_ch n ch | n LTEQ ILIT(0) = ""
1001               | otherwise      = ch : multi_ch (n MINUS ILIT(1)) ch
1002
1003 spaces n | n LTEQ ILIT(0) = ""
1004          | otherwise      = ' ' : spaces (n MINUS ILIT(1))
1005 \end{code}
1006
1007 \begin{code}
1008 pprCols = (120 :: Int) -- could make configurable
1009
1010 printDoc :: Mode -> Handle -> Doc -> IO ()
1011 printDoc LeftMode hdl doc
1012   = do { printLeftRender hdl doc; hFlush hdl }
1013 printDoc mode hdl doc
1014   = do { fullRender mode pprCols 1.5 put done doc ;
1015          hFlush hdl }
1016   where
1017     put (Chr c)  next = hPutChar hdl c >> next
1018     put (Str s)  next = hPutStr  hdl s >> next
1019     put (PStr s) next = hPutFS   hdl s >> next
1020     put (LStr s l) next = hPutLitString hdl s l >> next
1021
1022     done = hPutChar hdl '\n'
1023
1024   -- some versions of hPutBuf will barf if the length is zero
1025 hPutLitString handle a# 0# = return ()
1026 hPutLitString handle a# l#
1027   = hPutBuf handle (Ptr a#) (I# l#)
1028
1029 -- Printing output in LeftMode is performance critical: it's used when
1030 -- dumping C and assembly output, so we allow ourselves a few dirty
1031 -- hacks:
1032 --
1033 --      (1) we specialise fullRender for LeftMode with IO output.
1034 --
1035 --      (2) we add a layer of buffering on top of Handles.  Handles
1036 --          don't perform well with lots of hPutChars, which is mostly
1037 --          what we're doing here, because Handles have to be thread-safe
1038 --          and async exception-safe.  We only have a single thread and don't
1039 --          care about exceptions, so we add a layer of fast buffering
1040 --          over the Handle interface.
1041 --
1042 --      (3) a few hacks in layLeft below to convince GHC to generate the right
1043 --          code.
1044
1045 printLeftRender :: Handle -> Doc -> IO ()
1046 printLeftRender hdl doc = do
1047   b <- newBufHandle hdl
1048   layLeft b (reduceDoc doc)
1049   bFlush b
1050
1051 -- HACK ALERT!  the "return () >>" below convinces GHC to eta-expand
1052 -- this function with the IO state lambda.  Otherwise we end up with
1053 -- closures in all the case branches.
1054 layLeft b _ | b `seq` False = undefined -- make it strict in b
1055 layLeft b NoDoc                 = cant_fail
1056 layLeft b (Union p q)           = return () >> layLeft b (first p q)
1057 layLeft b (Nest k p)            = return () >> layLeft b p
1058 layLeft b Empty                 = bPutChar b '\n'
1059 layLeft b (NilAbove p)          = bPutChar b '\n' >> layLeft b p
1060 layLeft b (TextBeside s sl p)   = put b s >> layLeft b p
1061  where
1062     put b _ | b `seq` False = undefined
1063     put b (Chr c)    = bPutChar b c
1064     put b (Str s)    = bPutStr  b s
1065     put b (PStr s)   = bPutFS   b s
1066     put b (LStr s l) = bPutLitString b s l
1067 \end{code}