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