Text/PrettyPrint/HughesPJ.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Text.PrettyPrint.HughesPJ
   4 -- Copyright   :  (c) The University of Glasgow 2001
   5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  provisional
   9 -- Portability :  portable
  10 --
  11 -- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators
  12 --
  13 -- Based on /The Design of a Pretty-printing Library/
  14 -- in Advanced Functional Programming,
  15 -- Johan Jeuring and Erik Meijer (eds), LNCS 925
  16 -- <http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps>
  17 --
  18 -- Heavily modified by Simon Peyton Jones, Dec 96
  19 --
  20 -----------------------------------------------------------------------------
  21
  22 {-
  23 Version 3.0     28 May 1997
  24   * Cured massive performance bug.  If you write
  25
  26         foldl <> empty (map (text.show) [1..10000])
  27
  28     you get quadratic behaviour with V2.0.  Why?  For just the same
  29     reason as you get quadratic behaviour with left-associated (++)
  30     chains.
  31
  32     This is really bad news.  One thing a pretty-printer abstraction
  33     should certainly guarantee is insensivity to associativity.  It
  34     matters: suddenly GHC's compilation times went up by a factor of
  35     100 when I switched to the new pretty printer.
  36
  37     I fixed it with a bit of a hack (because I wanted to get GHC back
  38     on the road).  I added two new constructors to the Doc type, Above
  39     and Beside:
  40
  41          <> = Beside
  42          $$ = Above
  43
  44     Then, where I need to get to a "TextBeside" or "NilAbove" form I
  45     "force" the Doc to squeeze out these suspended calls to Beside and
  46     Above; but in so doing I re-associate. It's quite simple, but I'm
  47     not satisfied that I've done the best possible job.  I'll send you
  48     the code if you are interested.
  49
  50   * Added new exports:
  51         punctuate, hang
  52         int, integer, float, double, rational,
  53         lparen, rparen, lbrack, rbrack, lbrace, rbrace,
  54
  55   * fullRender's type signature has changed.  Rather than producing a
  56     string it now takes an extra couple of arguments that tells it how
  57     to glue fragments of output together:
  58
  59         fullRender :: Mode
  60                    -> Int                       -- Line length
  61                    -> Float                     -- Ribbons per line
  62                    -> (TextDetails -> a -> a)   -- What to do with text
  63                    -> a                         -- What to do at the end
  64                    -> Doc
  65                    -> a                         -- Result
  66
  67     The "fragments" are encapsulated in the TextDetails data type:
  68
  69         data TextDetails = Chr  Char
  70                          | Str  String
  71                          | PStr FAST_STRING
  72
  73     The Chr and Str constructors are obvious enough.  The PStr
  74     constructor has a packed string (FAST_STRING) inside it.  It's
  75     generated by using the new "ptext" export.
  76
  77     An advantage of this new setup is that you can get the renderer to
  78     do output directly (by passing in a function of type (TextDetails
  79     -> IO () -> IO ()), rather than producing a string that you then
  80     print.
  81
  82
  83 Version 2.0     24 April 1997
  84   * Made empty into a left unit for <> as well as a right unit;
  85     it is also now true that
  86         nest k empty = empty
  87     which wasn't true before.
  88
  89   * Fixed an obscure bug in sep that occassionally gave very weird behaviour
  90
  91   * Added $+$
  92
  93   * Corrected and tidied up the laws and invariants
  94
  95 ======================================================================
  96 Relative to John's original paper, there are the following new features:
  97
  98 1.  There's an empty document, "empty".  It's a left and right unit for
  99     both <> and $$, and anywhere in the argument list for
 100     sep, hcat, hsep, vcat, fcat etc.
 101
 102     It is Really Useful in practice.
 103
 104 2.  There is a paragraph-fill combinator, fsep, that's much like sep,
 105     only it keeps fitting things on one line until it can't fit any more.
 106
 107 3.  Some random useful extra combinators are provided.
 108         <+> puts its arguments beside each other with a space between them,
 109             unless either argument is empty in which case it returns the other
 110
 111
 112         hcat is a list version of <>
 113         hsep is a list version of <+>
 114         vcat is a list version of $$
 115
 116         sep (separate) is either like hsep or like vcat, depending on what fits
 117
 118         cat  behaves like sep,  but it uses <> for horizontal conposition
 119         fcat behaves like fsep, but it uses <> for horizontal conposition
 120
 121         These new ones do the obvious things:
 122                 char, semi, comma, colon, space,
 123                 parens, brackets, braces,
 124                 quotes, doubleQuotes
 125
 126 4.  The "above" combinator, $$, now overlaps its two arguments if the
 127     last line of the top argument stops before the first line of the
 128     second begins.
 129
 130         For example:  text "hi" $$ nest 5 "there"
 131         lays out as
 132                         hi   there
 133         rather than
 134                         hi
 135                              there
 136
 137         There are two places this is really useful
 138
 139         a) When making labelled blocks, like this:
 140                 Left ->   code for left
 141                 Right ->  code for right
 142                 LongLongLongLabel ->
 143                           code for longlonglonglabel
 144            The block is on the same line as the label if the label is
 145            short, but on the next line otherwise.
 146
 147         b) When laying out lists like this:
 148                 [ first
 149                 , second
 150                 , third
 151                 ]
 152            which some people like.  But if the list fits on one line
 153            you want [first, second, third].  You can't do this with
 154            John's original combinators, but it's quite easy with the
 155            new $$.
 156
 157         The combinator $+$ gives the original "never-overlap" behaviour.
 158
 159 5.      Several different renderers are provided:
 160                 * a standard one
 161                 * one that uses cut-marks to avoid deeply-nested documents
 162                         simply piling up in the right-hand margin
 163                 * one that ignores indentation (fewer chars output; good for machines)
 164                 * one that ignores indentation and newlines (ditto, only more so)
 165
 166 6.      Numerous implementation tidy-ups
 167         Use of unboxed data types to speed up the implementation
 168 -}
 169
 170 module Text.PrettyPrint.HughesPJ (
 171
 172         -- * The document type
 173         Doc,            -- Abstract
 174
 175         -- * Primitive Documents
 176         empty,
 177         semi, comma, colon, space, equals,
 178         lparen, rparen, lbrack, rbrack, lbrace, rbrace,
 179
 180         -- * Converting values into documents
 181         text, char, ptext,
 182         int, integer, float, double, rational,
 183
 184         -- * Wrapping documents in delimiters
 185         parens, brackets, braces, quotes, doubleQuotes,
 186
 187         -- * Combining documents
 188         (<>), (<+>), hcat, hsep,
 189         ($$), ($+$), vcat,
 190         sep, cat,
 191         fsep, fcat,
 192         nest,
 193         hang, punctuate,
 194
 195         -- * Predicates on documents
 196         isEmpty,
 197
 198         -- * Rendering documents
 199
 200         -- ** Default rendering
 201         render,
 202
 203         -- ** Rendering with a particular style
 204         Style(..),
 205         style,
 206         renderStyle,
 207
 208         -- ** General rendering
 209         fullRender,
 210         Mode(..), TextDetails(..),
 211
 212   ) where
 213
 214
 215 import Prelude
 216
 217 infixl 6 <>
 218 infixl 6 <+>
 219 infixl 5 $$, $+$
 220
 221 -- ---------------------------------------------------------------------------
 222 -- The interface
 223
 224 -- The primitive Doc values
 225
 226 isEmpty :: Doc    -> Bool;  -- ^ Returns 'True' if the document is empty
 227
 228 empty   :: Doc;                 -- ^ An empty document
 229 semi    :: Doc;                 -- ^ A ';' character
 230 comma   :: Doc;                 -- ^ A ',' character
 231 colon   :: Doc;                 -- ^ A ':' character
 232 space   :: Doc;                 -- ^ A space character
 233 equals  :: Doc;                 -- ^ A '=' character
 234 lparen  :: Doc;                 -- ^ A '(' character
 235 rparen  :: Doc;                 -- ^ A ')' character
 236 lbrack  :: Doc;                 -- ^ A '[' character
 237 rbrack  :: Doc;                 -- ^ A ']' character
 238 lbrace  :: Doc;                 -- ^ A '{' character
 239 rbrace  :: Doc;                 -- ^ A '}' character
 240
 241 text     :: String   -> Doc
 242 ptext    :: String   -> Doc
 243 char     :: Char     -> Doc
 244 int      :: Int      -> Doc
 245 integer  :: Integer  -> Doc
 246 float    :: Float    -> Doc
 247 double   :: Double   -> Doc
 248 rational :: Rational -> Doc
 249
 250
 251 parens       :: Doc -> Doc;     -- ^ Wrap document in @(...)@
 252 brackets     :: Doc -> Doc;     -- ^ Wrap document in @[...]@
 253 braces       :: Doc -> Doc;     -- ^ Wrap document in @{...}@
 254 quotes       :: Doc -> Doc;     -- ^ Wrap document in @'...'@
 255 doubleQuotes :: Doc -> Doc;     -- ^ Wrap document in @\"...\"@
 256
 257 -- Combining @Doc@ values
 258
 259 (<>)   :: Doc -> Doc -> Doc;     -- ^Beside
 260 hcat   :: [Doc] -> Doc;          -- ^List version of '<>'
 261 (<+>)  :: Doc -> Doc -> Doc;     -- ^Beside, separated by space
 262 hsep   :: [Doc] -> Doc;          -- ^List version of '<+>'
 263
 264 ($$)   :: Doc -> Doc -> Doc;     -- ^Above; if there is no
 265                                 -- overlap it \"dovetails\" the two
 266 vcat   :: [Doc] -> Doc;          -- ^List version of '$$'
 267
 268 cat    :: [Doc] -> Doc;          -- ^ Either hcat or vcat
 269 sep    :: [Doc] -> Doc;          -- ^ Either hsep or vcat
 270 fcat   :: [Doc] -> Doc;          -- ^ \"Paragraph fill\" version of cat
 271 fsep   :: [Doc] -> Doc;          -- ^ \"Paragraph fill\" version of sep
 272
 273 nest   :: Int -> Doc -> Doc;     -- ^ Nested
 274
 275
 276 -- GHC-specific ones.
 277
 278 hang :: Doc -> Int -> Doc -> Doc;       -- ^ @hang d1 n d2 = sep [d1, nest n d2]@
 279 punctuate :: Doc -> [Doc] -> [Doc];      -- ^ @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@
 280
 281
 282 -- Displaying @Doc@ values.
 283
 284 instance Show Doc where
 285   showsPrec prec doc cont = showDoc doc cont
 286
 287 -- | Renders the document as a string using the default style
 288 render     :: Doc -> String
 289
 290 -- | The general rendering interface
 291 fullRender :: Mode                      -- ^Rendering mode
 292            -> Int                       -- ^Line length
 293            -> Float                     -- ^Ribbons per line
 294            -> (TextDetails -> a -> a)   -- ^What to do with text
 295            -> a                         -- ^What to do at the end
 296            -> Doc                       -- ^The document
 297            -> a                         -- ^Result
 298
 299 -- | Render the document as a string using a specified style
 300 renderStyle  :: Style -> Doc -> String
 301
 302 -- | A rendering style
 303 data Style
 304  = Style { mode           :: Mode     -- ^ The rendering mode
 305          , lineLength     :: Int      -- ^ Length of line, in chars
 306          , ribbonsPerLine :: Float    -- ^ Ratio of ribbon length to line length
 307          }
 308
 309 -- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@)
 310 style :: Style
 311 style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode }
 312
 313 -- | Rendering mode
 314 data Mode = PageMode            -- ^Normal
 315           | ZigZagMode          -- ^With zig-zag cuts
 316           | LeftMode            -- ^No indentation, infinitely long lines
 317           | OneLineMode         -- ^All on one line
 318
 319 -- ---------------------------------------------------------------------------
 320 -- The Doc calculus
 321
 322 -- The Doc combinators satisfy the following laws:
 323
 324 {-
 325 Laws for $$
 326 ~~~~~~~~~~~
 327 <a1>    (x $$ y) $$ z   = x $$ (y $$ z)
 328 <a2>    empty $$ x      = x
 329 <a3>    x $$ empty      = x
 330
 331         ...ditto $+$...
 332
 333 Laws for <>
 334 ~~~~~~~~~~~
 335 <b1>    (x <> y) <> z   = x <> (y <> z)
 336 <b2>    empty <> x      = empty
 337 <b3>    x <> empty      = x
 338
 339         ...ditto <+>...
 340
 341 Laws for text
 342 ~~~~~~~~~~~~~
 343 <t1>    text s <> text t        = text (s++t)
 344 <t2>    text "" <> x            = x, if x non-empty
 345
 346 Laws for nest
 347 ~~~~~~~~~~~~~
 348 <n1>    nest 0 x                = x
 349 <n2>    nest k (nest k' x)      = nest (k+k') x
 350 <n3>    nest k (x <> y)         = nest k z <> nest k y
 351 <n4>    nest k (x $$ y)         = nest k x $$ nest k y
 352 <n5>    nest k empty            = empty
 353 <n6>    x <> nest k y           = x <> y, if x non-empty
 354
 355 ** Note the side condition on <n6>!  It is this that
 356 ** makes it OK for empty to be a left unit for <>.
 357
 358 Miscellaneous
 359 ~~~~~~~~~~~~~
 360 <m1>    (text s <> x) $$ y = text s <> ((text "" <> x)) $$
 361                                          nest (-length s) y)
 362
 363 <m2>    (x $$ y) <> z = x $$ (y <> z)
 364         if y non-empty
 365
 366
 367 Laws for list versions
 368 ~~~~~~~~~~~~~~~~~~~~~~
 369 <l1>    sep (ps++[empty]++qs)   = sep (ps ++ qs)
 370         ...ditto hsep, hcat, vcat, fill...
 371
 372 <l2>    nest k (sep ps) = sep (map (nest k) ps)
 373         ...ditto hsep, hcat, vcat, fill...
 374
 375 Laws for oneLiner
 376 ~~~~~~~~~~~~~~~~~
 377 <o1>    oneLiner (nest k p) = nest k (oneLiner p)
 378 <o2>    oneLiner (x <> y)   = oneLiner x <> oneLiner y
 379
 380 You might think that the following verion of <m1> would
 381 be neater:
 382
 383 <3 NO>  (text s <> x) $$ y = text s <> ((empty <> x)) $$
 384                                          nest (-length s) y)
 385
 386 But it doesn't work, for if x=empty, we would have
 387
 388         text s $$ y = text s <> (empty $$ nest (-length s) y)
 389                     = text s <> nest (-length s) y
 390 -}
 391
 392 -- ---------------------------------------------------------------------------
 393 -- Simple derived definitions
 394
 395 semi  = char ';'
 396 colon = char ':'
 397 comma = char ','
 398 space = char ' '
 399 equals = char '='
 400 lparen = char '('
 401 rparen = char ')'
 402 lbrack = char '['
 403 rbrack = char ']'
 404 lbrace = char '{'
 405 rbrace = char '}'
 406
 407 int      n = text (show n)
 408 integer  n = text (show n)
 409 float    n = text (show n)
 410 double   n = text (show n)
 411 rational n = text (show n)
 412 -- SIGBJORN wrote instead:
 413 -- rational n = text (show (fromRationalX n))
 414
 415 quotes p        = char '`' <> p <> char '\''
 416 doubleQuotes p  = char '"' <> p <> char '"'
 417 parens p        = char '(' <> p <> char ')'
 418 brackets p      = char '[' <> p <> char ']'
 419 braces p        = char '{' <> p <> char '}'
 420
 421
 422 hcat = foldr (<>)  empty
 423 hsep = foldr (<+>) empty
 424 vcat = foldr ($$)  empty
 425
 426 hang d1 n d2 = sep [d1, nest n d2]
 427
 428 punctuate p []     = []
 429 punctuate p (d:ds) = go d ds
 430                    where
 431                      go d [] = [d]
 432                      go d (e:es) = (d <> p) : go e es
 433
 434 -- ---------------------------------------------------------------------------
 435 -- The Doc data type
 436
 437 -- A Doc represents a *set* of layouts.  A Doc with
 438 -- no occurrences of Union or NoDoc represents just one layout.
 439
 440 -- | The abstract type of documents
 441 data Doc
 442  = Empty                                -- empty
 443  | NilAbove Doc                         -- text "" $$ x
 444  | TextBeside TextDetails !Int Doc      -- text s <> x
 445  | Nest !Int Doc                        -- nest k x
 446  | Union Doc Doc                        -- ul `union` ur
 447  | NoDoc                                -- The empty set of documents
 448  | Beside Doc Bool Doc                  -- True <=> space between
 449  | Above  Doc Bool Doc                  -- True <=> never overlap
 450
 451 type RDoc = Doc         -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
 452
 453
 454 reduceDoc :: Doc -> RDoc
 455 reduceDoc (Beside p g q) = beside p g (reduceDoc q)
 456 reduceDoc (Above  p g q) = above  p g (reduceDoc q)
 457 reduceDoc p              = p
 458
 459
 460 data TextDetails = Chr  Char
 461                  | Str  String
 462                  | PStr String
 463 space_text = Chr ' '
 464 nl_text    = Chr '\n'
 465
 466 {-
 467   Here are the invariants:
 468
 469   * The argument of NilAbove is never Empty. Therefore
 470     a NilAbove occupies at least two lines.
 471
 472   * The arugment of @TextBeside@ is never @Nest@.
 473
 474
 475   * The layouts of the two arguments of @Union@ both flatten to the same
 476     string.
 477
 478   * The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
 479
 480   * The right argument of a union cannot be equivalent to the empty set
 481     (@NoDoc@).  If the left argument of a union is equivalent to the
 482     empty set (@NoDoc@), then the @NoDoc@ appears in the first line.
 483
 484   * An empty document is always represented by @Empty@.  It can't be
 485     hidden inside a @Nest@, or a @Union@ of two @Empty@s.
 486
 487   * The first line of every layout in the left argument of @Union@ is
 488     longer than the first line of any layout in the right argument.
 489     (1) ensures that the left argument has a first line.  In view of
 490     (3), this invariant means that the right argument must have at
 491     least two lines.
 492 -}
 493
 494         -- Arg of a NilAbove is always an RDoc
 495 nilAbove_ p = NilAbove p
 496
 497         -- Arg of a TextBeside is always an RDoc
 498 textBeside_ s sl p = TextBeside s sl p
 499
 500         -- Arg of Nest is always an RDoc
 501 nest_ k p = Nest k p
 502
 503         -- Args of union are always RDocs
 504 union_ p q = Union p q
 505
 506
 507 -- Notice the difference between
 508 --         * NoDoc (no documents)
 509 --         * Empty (one empty document; no height and no width)
 510 --         * text "" (a document containing the empty string;
 511 --                    one line high, but has no width)
 512
 513
 514 -- ---------------------------------------------------------------------------
 515 -- @empty@, @text@, @nest@, @union@
 516
 517 empty = Empty
 518
 519 isEmpty Empty = True
 520 isEmpty _     = False
 521
 522 char  c = textBeside_ (Chr c) 1 Empty
 523 text  s = case length   s of {sl -> textBeside_ (Str s)  sl Empty}
 524 ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty}
 525
 526 nest k  p = mkNest k (reduceDoc p)        -- Externally callable version
 527
 528 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
 529 mkNest k       _           | k `seq` False = undefined
 530 mkNest k       (Nest k1 p) = mkNest (k + k1) p
 531 mkNest k       NoDoc       = NoDoc
 532 mkNest k       Empty       = Empty
 533 mkNest 0       p           = p                  -- Worth a try!
 534 mkNest k       p           = nest_ k p
 535
 536 -- mkUnion checks for an empty document
 537 mkUnion Empty q = Empty
 538 mkUnion p q     = p `union_` q
 539
 540 -- ---------------------------------------------------------------------------
 541 -- Vertical composition @$$@
 542
 543 p $$  q = Above p False q
 544 p $+$ q = Above p True q
 545
 546 above :: Doc -> Bool -> RDoc -> RDoc
 547 above (Above p g1 q1)  g2 q2 = above p g1 (above q1 g2 q2)
 548 above p@(Beside _ _ _) g  q  = aboveNest (reduceDoc p) g 0 (reduceDoc q)
 549 above p g q                  = aboveNest p             g 0 (reduceDoc q)
 550
 551 aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
 552 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
 553
 554 aboveNest _                   _ k _ | k `seq` False = undefined
 555 aboveNest NoDoc               g k q = NoDoc
 556 aboveNest (p1 `Union` p2)     g k q = aboveNest p1 g k q `union_`
 557                                       aboveNest p2 g k q
 558
 559 aboveNest Empty               g k q = mkNest k q
 560 aboveNest (Nest k1 p)         g k q = nest_ k1 (aboveNest p g (k - k1) q)
 561                                   -- p can't be Empty, so no need for mkNest
 562
 563 aboveNest (NilAbove p)        g k q = nilAbove_ (aboveNest p g k q)
 564 aboveNest (TextBeside s sl p) g k q = k1 `seq` textBeside_ s sl rest
 565                                     where
 566                                       k1   = k - sl
 567                                       rest = case p of
 568                                                 Empty -> nilAboveNest g k1 q
 569                                                 other -> aboveNest  p g k1 q
 570
 571
 572 nilAboveNest :: Bool -> Int -> RDoc -> RDoc
 573 -- Specification: text s <> nilaboveNest g k q
 574 --              = text s <> (text "" $g$ nest k q)
 575
 576 nilAboveNest _ k _           | k `seq` False = undefined
 577 nilAboveNest g k Empty       = Empty    -- Here's why the "text s <>" is in the spec!
 578 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
 579
 580 nilAboveNest g k q           | (not g) && (k > 0)        -- No newline if no overlap
 581                              = textBeside_ (Str (spaces k)) k q
 582                              | otherwise                        -- Put them really above
 583                              = nilAbove_ (mkNest k q)
 584
 585 -- ---------------------------------------------------------------------------
 586 -- Horizontal composition @<>@
 587
 588 p <>  q = Beside p False q
 589 p <+> q = Beside p True  q
 590
 591 beside :: Doc -> Bool -> RDoc -> RDoc
 592 -- Specification: beside g p q = p <g> q
 593
 594 beside NoDoc               g q   = NoDoc
 595 beside (p1 `Union` p2)     g q   = (beside p1 g q) `union_` (beside p2 g q)
 596 beside Empty               g q   = q
 597 beside (Nest k p)          g q   = nest_ k (beside p g q)       -- p non-empty
 598 beside p@(Beside p1 g1 q1) g2 q2
 599            {- (A `op1` B) `op2` C == A `op1` (B `op2` C)  iff op1 == op2
 600                                                  [ && (op1 == <> || op1 == <+>) ] -}
 601          | g1 == g2              = beside p1 g1 (beside q1 g2 q2)
 602          | otherwise             = beside (reduceDoc p) g2 q2
 603 beside p@(Above _ _ _)     g q   = beside (reduceDoc p) g q
 604 beside (NilAbove p)        g q   = nilAbove_ (beside p g q)
 605 beside (TextBeside s sl p) g q   = textBeside_ s sl rest
 606                                where
 607                                   rest = case p of
 608                                            Empty -> nilBeside g q
 609                                            other -> beside p g q
 610
 611
 612 nilBeside :: Bool -> RDoc -> RDoc
 613 -- Specification: text "" <> nilBeside g p
 614 --              = text "" <g> p
 615
 616 nilBeside g Empty      = Empty  -- Hence the text "" in the spec
 617 nilBeside g (Nest _ p) = nilBeside g p
 618 nilBeside g p          | g         = textBeside_ space_text 1 p
 619                        | otherwise = p
 620
 621 -- ---------------------------------------------------------------------------
 622 -- Separate, @sep@, Hughes version
 623
 624 -- Specification: sep ps  = oneLiner (hsep ps)
 625 --                         `union`
 626 --                          vcat ps
 627
 628 sep = sepX True         -- Separate with spaces
 629 cat = sepX False        -- Don't
 630
 631 sepX x []     = empty
 632 sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
 633
 634
 635 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
 636 --                            = oneLiner (x <g> nest k (hsep ys))
 637 --                              `union` x $$ nest k (vcat ys)
 638
 639 sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
 640 sep1 g _                   k ys | k `seq` False = undefined
 641 sep1 g NoDoc               k ys = NoDoc
 642 sep1 g (p `Union` q)       k ys = sep1 g p k ys
 643                                   `union_`
 644                                   (aboveNest q False k (reduceDoc (vcat ys)))
 645
 646 sep1 g Empty               k ys = mkNest k (sepX g ys)
 647 sep1 g (Nest n p)          k ys = nest_ n (sep1 g p (k - n) ys)
 648
 649 sep1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
 650 sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)
 651
 652 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
 653 -- Called when we have already found some text in the first item
 654 -- We have to eat up nests
 655
 656 sepNB g (Nest _ p)  k ys  = sepNB g p k ys
 657
 658 sepNB g Empty k ys        = oneLiner (nilBeside g (reduceDoc rest))
 659                                 `mkUnion`
 660                             nilAboveNest False k (reduceDoc (vcat ys))
 661                           where
 662                             rest | g         = hsep ys
 663                                  | otherwise = hcat ys
 664
 665 sepNB g p k ys            = sep1 g p k ys
 666
 667 -- ---------------------------------------------------------------------------
 668 -- @fill@
 669
 670 fsep = fill True
 671 fcat = fill False
 672
 673 -- Specification:
 674 --   fill []  = empty
 675 --   fill [p] = p
 676 --   fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
 677 --                                          (fill (oneLiner p2 : ps))
 678 --                     `union`
 679 --                      p1 $$ fill ps
 680
 681 fill g []     = empty
 682 fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
 683
 684
 685 fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
 686 fill1 g _                   k ys | k `seq` False = undefined
 687 fill1 g NoDoc               k ys = NoDoc
 688 fill1 g (p `Union` q)       k ys = fill1 g p k ys
 689                                    `union_`
 690                                    (aboveNest q False k (fill g ys))
 691
 692 fill1 g Empty               k ys = mkNest k (fill g ys)
 693 fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k - n) ys)
 694
 695 fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fill g ys))
 696 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
 697
 698 fillNB g _           k ys | k `seq` False = undefined
 699 fillNB g (Nest _ p)  k ys  = fillNB g p k ys
 700 fillNB g Empty k []        = Empty
 701 fillNB g Empty k (y:ys)    = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
 702                              `mkUnion`
 703                              nilAboveNest False k (fill g (y:ys))
 704                            where
 705                              k1 | g         = k - 1
 706                                 | otherwise = k
 707
 708 fillNB g p k ys            = fill1 g p k ys
 709
 710
 711 -- ---------------------------------------------------------------------------
 712 -- Selecting the best layout
 713
 714 best :: Mode
 715      -> Int             -- Line length
 716      -> Int             -- Ribbon length
 717      -> RDoc
 718      -> RDoc            -- No unions in here!
 719
 720 best OneLineMode w r p
 721   = get p
 722   where
 723     get Empty               = Empty
 724     get NoDoc               = NoDoc
 725     get (NilAbove p)        = nilAbove_ (get p)
 726     get (TextBeside s sl p) = textBeside_ s sl (get p)
 727     get (Nest k p)          = get p             -- Elide nest
 728     get (p `Union` q)       = first (get p) (get q)
 729
 730 best mode w r p
 731   = get w p
 732   where
 733     get :: Int          -- (Remaining) width of line
 734         -> Doc -> Doc
 735     get w _ | w==0 && False   = undefined
 736     get w Empty               = Empty
 737     get w NoDoc               = NoDoc
 738     get w (NilAbove p)        = nilAbove_ (get w p)
 739     get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
 740     get w (Nest k p)          = nest_ k (get (w - k) p)
 741     get w (p `Union` q)       = nicest w r (get w p) (get w q)
 742
 743     get1 :: Int         -- (Remaining) width of line
 744          -> Int         -- Amount of first line already eaten up
 745          -> Doc         -- This is an argument to TextBeside => eat Nests
 746          -> Doc         -- No unions in here!
 747
 748     get1 w _ _ | w==0 && False = undefined
 749     get1 w sl Empty               = Empty
 750     get1 w sl NoDoc               = NoDoc
 751     get1 w sl (NilAbove p)        = nilAbove_ (get (w - sl) p)
 752     get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)
 753     get1 w sl (Nest k p)          = get1 w sl p
 754     get1 w sl (p `Union` q)       = nicest1 w r sl (get1 w sl p)
 755                                                    (get1 w sl q)
 756
 757 nicest w r p q = nicest1 w r 0 p q
 758 nicest1 w r sl p q | fits ((w `minn` r) - sl) p = p
 759                    | otherwise                   = q
 760
 761 fits :: Int     -- Space available
 762      -> Doc
 763      -> Bool    -- True if *first line* of Doc fits in space available
 764
 765 fits n p    | n < 0 = False
 766 fits n NoDoc               = False
 767 fits n Empty               = True
 768 fits n (NilAbove _)        = True
 769 fits n (TextBeside _ sl p) = fits (n - sl) p
 770
 771 minn x y | x < y    = x
 772          | otherwise = y
 773
 774 -- @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
 775 -- @first@ returns its first argument if it is non-empty, otherwise its second.
 776
 777 first p q | nonEmptySet p = p
 778           | otherwise     = q
 779
 780 nonEmptySet NoDoc           = False
 781 nonEmptySet (p `Union` q)      = True
 782 nonEmptySet Empty              = True
 783 nonEmptySet (NilAbove p)       = True           -- NoDoc always in first line
 784 nonEmptySet (TextBeside _ _ p) = nonEmptySet p
 785 nonEmptySet (Nest _ p)         = nonEmptySet p
 786
 787 -- @oneLiner@ returns the one-line members of the given set of @Doc@s.
 788
 789 oneLiner :: Doc -> Doc
 790 oneLiner NoDoc               = NoDoc
 791 oneLiner Empty               = Empty
 792 oneLiner (NilAbove p)        = NoDoc
 793 oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
 794 oneLiner (Nest k p)          = nest_ k (oneLiner p)
 795 oneLiner (p `Union` q)       = oneLiner p
 796
 797
 798 -- ---------------------------------------------------------------------------
 799 -- Displaying the best layout
 800
 801 renderStyle style doc
 802   = fullRender (mode style)
 803                (lineLength style)
 804                (ribbonsPerLine style)
 805                string_txt
 806                ""
 807                doc
 808
 809 render doc       = showDoc doc ""
 810 showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc
 811
 812 string_txt (Chr c)   s  = c:s
 813 string_txt (Str s1)  s2 = s1 ++ s2
 814 string_txt (PStr s1) s2 = s1 ++ s2
 815
 816
 817 fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc)
 818 fullRender LeftMode    _ _ txt end doc = easy_display nl_text    txt end (reduceDoc doc)
 819
 820 fullRender mode line_length ribbons_per_line txt end doc
 821   = display mode line_length ribbon_length txt end best_doc
 822   where
 823     best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc)
 824
 825     hacked_line_length, ribbon_length :: Int
 826     ribbon_length = round (fromIntegral line_length / ribbons_per_line)
 827     hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length }
 828
 829 display mode page_width ribbon_width txt end doc
 830   = case page_width - ribbon_width of { gap_width ->
 831     case gap_width `quot` 2 of { shift ->
 832     let
 833         lay k _            | k `seq` False = undefined
 834         lay k (Nest k1 p)  = lay (k + k1) p
 835         lay k Empty        = end
 836
 837         lay k (NilAbove p) = nl_text `txt` lay k p
 838
 839         lay k (TextBeside s sl p)
 840             = case mode of
 841                     ZigZagMode |  k >= gap_width
 842                                -> nl_text `txt` (
 843                                   Str (multi_ch shift '/') `txt` (
 844                                   nl_text `txt` (
 845                                   lay1 (k - shift) s sl p)))
 846
 847                                |  k < 0
 848                                -> nl_text `txt` (
 849                                   Str (multi_ch shift '\\') `txt` (
 850                                   nl_text `txt` (
 851                                   lay1 (k + shift) s sl p )))
 852
 853                     other -> lay1 k s sl p
 854
 855         lay1 k _ sl _ | k+sl `seq` False = undefined
 856         lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p)
 857
 858         lay2 k _ | k `seq` False = undefined
 859         lay2 k (NilAbove p)        = nl_text `txt` lay k p
 860         lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p)
 861         lay2 k (Nest _ p)          = lay2 k p
 862         lay2 k Empty               = end
 863     in
 864     lay 0 doc
 865     }}
 866
 867 cant_fail = error "easy_display: NoDoc"
 868 easy_display nl_text txt end doc
 869   = lay doc cant_fail
 870   where
 871     lay NoDoc               no_doc = no_doc
 872     lay (Union p q)         no_doc = {- lay p -} (lay q cant_fail)              -- Second arg can't be NoDoc
 873     lay (Nest k p)          no_doc = lay p no_doc
 874     lay Empty               no_doc = end
 875     lay (NilAbove p)        no_doc = nl_text `txt` lay p cant_fail      -- NoDoc always on first line
 876     lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc
 877
 878 indent n | n >= 8 = '\t' : indent (n - 8)
 879          | otherwise      = spaces n
 880
 881 multi_ch 0 ch = ""
 882 multi_ch n       ch = ch : multi_ch (n - 1) ch
 883
 884 -- (spaces n) generates a list of n spaces
 885 --
 886 -- It should never be called with 'n' < 0, but that can happen for reasons I don't understand
 887 -- Here's a test case:
 888 --      ncat x y = nest 4 $ cat [ x, y ]
 889 --      d1 = foldl1 ncat $ take 50 $ repeat $ char 'a'
 890 --      d2 = parens $  sep [ d1, text "+" , d1 ]
 891 --      main = print d2
 892 -- I don't feel motivated enough to find the Real Bug, so meanwhile we just test for n<=0
 893 spaces n | n <= 0    = ""
 894          | otherwise = ' ' : spaces (n - 1)
 895
 896 {- Comments from Johannes Waldmann about what the problem might be:
 897
 898    In the example above, d2 and d1 are deeply nested, but `text "+"' is not,
 899    so the layout function tries to "out-dent" it.
 900
 901    when I look at the Doc values that are generated, there are lots of
 902    Nest constructors with negative arguments.  see this sample output of
 903    d1 (obtained with hugs, :s -u)
 904
 905    tBeside (TextDetails_Chr 'a') 1 Doc_Empty) (Doc_NilAbove (Doc_Nest
 906    (-241) (Doc_TextBeside (TextDetails_Chr 'a') 1 Doc_Empty)))))
 907    (Doc_NilAbove (Doc_Nest (-236) (Doc_TextBeside (TextDetails_Chr 'a') 1
 908    (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside (TextDetails_Chr 'a') 1
 909    Doc_Empty)))))))) (Doc_NilAbove (Doc_Nest (-231) (Doc_TextBeside
 910    (TextDetails_Chr 'a') 1 (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside
 911    (TextDetails_Chr 'a') 1 (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside
 912    (TextDetails_Chr 'a') 1 Doc_Empty))))))))))) (Doc_NilAbove (Doc_Nest
 913 -}