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