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