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