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