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