ghc/lib/exts/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 = sep [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 _                   k ys | k == 0 && False = undefined
 650 sep1 g NoDoc               k ys = NoDoc
 651 sep1 g (p `Union` q)       k ys = sep1 g p k ys
 652                                   `union_`
 653                                   (aboveNest q False k (reduceDoc (vcat ys)))
 654
 655 sep1 g Empty               k ys = mkNest k (sepX g ys)
 656 sep1 g (Nest n p)          k ys = nest_ n (sep1 g p (k - n) ys)
 657
 658 sep1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
 659 sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)
 660
 661 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
 662 -- Called when we have already found some text in the first item
 663 -- We have to eat up nests
 664
 665 sepNB g (Nest _ p)  k ys  = sepNB g p k ys
 666
 667 sepNB g Empty k ys        = oneLiner (nilBeside g (reduceDoc rest))
 668                                 `mkUnion`
 669                             nilAboveNest False k (reduceDoc (vcat ys))
 670                           where
 671                             rest | g         = hsep ys
 672                                  | otherwise = hcat ys
 673
 674 sepNB g p k ys            = sep1 g p k ys
 675 \end{code}
 676
 677 *********************************************************
 678 *                                                       *
 679 \subsection{@fill@}
 680 *                                                       *
 681 *********************************************************
 682
 683 \begin{code}
 684 fsep = fill True
 685 fcat = fill False
 686
 687 -- Specification:
 688 --   fill []  = empty
 689 --   fill [p] = p
 690 --   fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
 691 --                                          (fill (oneLiner p2 : ps))
 692 --                     `union`
 693 --                      p1 $$ fill ps
 694
 695 fill g []     = empty
 696 fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
 697
 698
 699 fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
 700 fill1 g _                   k ys | k == 0 && False = undefined
 701 fill1 g NoDoc               k ys = NoDoc
 702 fill1 g (p `Union` q)       k ys = fill1 g p k ys
 703                                    `union_`
 704                                    (aboveNest q False k (fill g ys))
 705
 706 fill1 g Empty               k ys = mkNest k (fill g ys)
 707 fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k - n) ys)
 708
 709 fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fill g ys))
 710 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
 711
 712 fillNB g _           k ys | k == 0 && False = undefined
 713 fillNB g (Nest _ p)  k ys  = fillNB g p k ys
 714 fillNB g Empty k []        = Empty
 715 fillNB g Empty k (y:ys)    = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
 716                              `mkUnion`
 717                              nilAboveNest False k (fill g (y:ys))
 718                            where
 719                              k1 | g         = k - 1
 720                                 | otherwise = k
 721
 722 fillNB g p k ys            = fill1 g p k ys
 723 \end{code}
 724
 725
 726 *********************************************************
 727 *                                                       *
 728 \subsection{Selecting the best layout}
 729 *                                                       *
 730 *********************************************************
 731
 732 \begin{code}
 733 best :: Mode
 734      -> Int             -- Line length
 735      -> Int             -- Ribbon length
 736      -> RDoc
 737      -> RDoc            -- No unions in here!
 738
 739 best OneLineMode w r p
 740   = get p
 741   where
 742     get Empty               = Empty
 743     get NoDoc               = NoDoc
 744     get (NilAbove p)        = nilAbove_ (get p)
 745     get (TextBeside s sl p) = textBeside_ s sl (get p)
 746     get (Nest k p)          = get p             -- Elide nest
 747     get (p `Union` q)       = first (get p) (get q)
 748
 749 best mode w r p
 750   = get w p
 751   where
 752     get :: Int          -- (Remaining) width of line
 753         -> Doc -> Doc
 754     get w _ | w==0 && False   = undefined
 755     get w Empty               = Empty
 756     get w NoDoc               = NoDoc
 757     get w (NilAbove p)        = nilAbove_ (get w p)
 758     get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
 759     get w (Nest k p)          = nest_ k (get (w - k) p)
 760     get w (p `Union` q)       = nicest w r (get w p) (get w q)
 761
 762     get1 :: Int         -- (Remaining) width of line
 763          -> Int         -- Amount of first line already eaten up
 764          -> Doc         -- This is an argument to TextBeside => eat Nests
 765          -> Doc         -- No unions in here!
 766
 767     get1 w _ _ | w==0 && False = undefined
 768     get1 w sl Empty               = Empty
 769     get1 w sl NoDoc               = NoDoc
 770     get1 w sl (NilAbove p)        = nilAbove_ (get (w - sl) p)
 771     get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)
 772     get1 w sl (Nest k p)          = get1 w sl p
 773     get1 w sl (p `Union` q)       = nicest1 w r sl (get1 w sl p)
 774                                                    (get1 w sl q)
 775
 776 nicest w r p q = nicest1 w r 0 p q
 777 nicest1 w r sl p q | fits ((w `minn` r) - sl) p = p
 778                    | otherwise                   = q
 779
 780 fits :: Int     -- Space available
 781      -> Doc
 782      -> Bool    -- True if *first line* of Doc fits in space available
 783
 784 fits n p    | n < 0 = False
 785 fits n NoDoc               = False
 786 fits n Empty               = True
 787 fits n (NilAbove _)        = True
 788 fits n (TextBeside _ sl p) = (fits $! (n - sl)) p
 789
 790 minn x y | x < y    = x
 791          | otherwise = y
 792 \end{code}
 793
 794 @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
 795 @first@ returns its first argument if it is non-empty, otherwise its second.
 796
 797 \begin{code}
 798 first p q | nonEmptySet p = p
 799           | otherwise     = q
 800
 801 nonEmptySet NoDoc           = False
 802 nonEmptySet (p `Union` q)      = True
 803 nonEmptySet Empty              = True
 804 nonEmptySet (NilAbove p)       = True           -- NoDoc always in first line
 805 nonEmptySet (TextBeside _ _ p) = nonEmptySet p
 806 nonEmptySet (Nest _ p)         = nonEmptySet p
 807 \end{code}
 808
 809 @oneLiner@ returns the one-line members of the given set of @Doc@s.
 810
 811 \begin{code}
 812 oneLiner :: Doc -> Doc
 813 oneLiner NoDoc               = NoDoc
 814 oneLiner Empty               = Empty
 815 oneLiner (NilAbove p)        = NoDoc
 816 oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
 817 oneLiner (Nest k p)          = nest_ k (oneLiner p)
 818 oneLiner (p `Union` q)       = oneLiner p
 819 \end{code}
 820
 821
 822
 823 *********************************************************
 824 *                                                       *
 825 \subsection{Displaying the best layout}
 826 *                                                       *
 827 *********************************************************
 828
 829
 830 \begin{code}
 831 {-
 832 renderStyle Style{mode, lineLength, ribbonsPerLine} doc
 833   = fullRender mode lineLength ribbonsPerLine doc ""
 834 -}
 835
 836 render doc       = showDoc doc ""
 837 showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc
 838
 839 string_txt (Chr c)   s  = c:s
 840 string_txt (Str s1)  s2 = s1 ++ s2
 841 string_txt (PStr s1) s2 = s1 ++ s2
 842 \end{code}
 843
 844 \begin{code}
 845
 846 fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc)
 847 fullRender LeftMode    _ _ txt end doc = easy_display nl_text    txt end (reduceDoc doc)
 848
 849 fullRender mode line_length ribbons_per_line txt end doc
 850   = display mode line_length ribbon_length txt end best_doc
 851   where
 852     best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc)
 853
 854     hacked_line_length, ribbon_length :: Int
 855     ribbon_length = round (fromIntegral line_length / ribbons_per_line)
 856     hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length }
 857
 858 display mode page_width ribbon_width txt end doc
 859   = case page_width - ribbon_width of { gap_width ->
 860     case gap_width `quot` 2 of { shift ->
 861     let
 862         lay k (Nest k1 p)  = lay (k + k1) p
 863         lay k Empty        = end
 864
 865         lay k (NilAbove p) = nl_text `txt` lay k p
 866
 867         lay k (TextBeside s sl p)
 868             = case mode of
 869                     ZigZagMode |  k >= gap_width
 870                                -> nl_text `txt` (
 871                                   Str (multi_ch shift '/') `txt` (
 872                                   nl_text `txt` (
 873                                   lay1 (k - shift) s sl p)))
 874
 875                                |  k < 0
 876                                -> nl_text `txt` (
 877                                   Str (multi_ch shift '\\') `txt` (
 878                                   nl_text `txt` (
 879                                   lay1 (k + shift) s sl p )))
 880
 881                     other -> lay1 k s sl p
 882
 883         lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p)
 884
 885         lay2 k (NilAbove p)        = nl_text `txt` lay k p
 886         lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p)
 887         lay2 k (Nest _ p)          = lay2 k p
 888         lay2 k Empty               = end
 889     in
 890     lay 0 doc
 891     }}
 892
 893 cant_fail = error "easy_display: NoDoc"
 894 easy_display nl_text txt end doc
 895   = lay doc cant_fail
 896   where
 897     lay NoDoc               no_doc = no_doc
 898     lay (Union p q)         no_doc = {- lay p -} (lay q cant_fail)              -- Second arg can't be NoDoc
 899     lay (Nest k p)          no_doc = lay p no_doc
 900     lay Empty               no_doc = end
 901     lay (NilAbove p)        no_doc = nl_text `txt` lay p cant_fail      -- NoDoc always on first line
 902     lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc
 903
 904 indent n | n >= 8 = '\t' : indent (n - 8)
 905          | otherwise      = spaces n
 906
 907 multi_ch 0 ch = ""
 908 multi_ch n       ch = ch : multi_ch (n - 1) ch
 909
 910 spaces 0 = ""
 911 spaces n       = ' ' : spaces (n - 1)
 912 \end{code}
 913