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