ghc/compiler/utils/Pretty.lhs

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