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