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