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