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