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