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