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