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