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