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