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