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