Pretty.lhs 37.2 KB
Newer Older
Thomas Schilling's avatar
Thomas Schilling committed
1 2 3 4 5 6 7 8 9 10 11 12
%*********************************************************************************
%*                                                                               *
%*       John Hughes's and Simon Peyton Jones's Pretty Printer Combinators       *
%*                                                                               *
%*               based on "The Design of a Pretty-printing Library"              *
%*               in Advanced Functional Programming,                             *
%*               Johan Jeuring and Erik Meijer (eds), LNCS 925                   *
%*               http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps                *
%*                                                                               *
%*               Heavily modified by Simon Peyton Jones, Dec 96                  *
%*                                                                               *
%*********************************************************************************
sof's avatar
sof committed
13

sof's avatar
sof committed
14 15 16 17 18 19 20 21 22 23 24 25
Version 3.0     28 May 1997
  * Cured massive performance bug.  If you write

        foldl <> empty (map (text.show) [1..10000])

    you get quadratic behaviour with V2.0.  Why?  For just the same reason as you get
    quadratic behaviour with left-associated (++) chains.

    This is really bad news.  One thing a pretty-printer abstraction should
    certainly guarantee is insensivity to associativity.  It matters: suddenly
    GHC's compilation times went up by a factor of 100 when I switched to the
    new pretty printer.
Ian Lynagh's avatar
Ian Lynagh committed
26

sof's avatar
sof committed
27 28
    I fixed it with a bit of a hack (because I wanted to get GHC back on the
    road).  I added two new constructors to the Doc type, Above and Beside:
Ian Lynagh's avatar
Ian Lynagh committed
29

sof's avatar
sof committed
30 31
         <> = Beside
         $$ = Above
Ian Lynagh's avatar
Ian Lynagh committed
32

sof's avatar
sof committed
33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57
    Then, where I need to get to a "TextBeside" or "NilAbove" form I "force"
    the Doc to squeeze out these suspended calls to Beside and Above; but in so
    doing I re-associate. It's quite simple, but I'm not satisfied that I've done
    the best possible job.  I'll send you the code if you are interested.

  * Added new exports:
        punctuate, hang
        int, integer, float, double, rational,
        lparen, rparen, lbrack, rbrack, lbrace, rbrace,

  * fullRender's type signature has changed.  Rather than producing a string it
    now takes an extra couple of arguments that tells it how to glue fragments
    of output together:

        fullRender :: Mode
                   -> Int                       -- Line length
                   -> Float                     -- Ribbons per line
                   -> (TextDetails -> a -> a)   -- What to do with text
                   -> a                         -- What to do at the end
                   -> Doc
                   -> a                         -- Result

    The "fragments" are encapsulated in the TextDetails data type:
        data TextDetails = Chr  Char
                         | Str  String
58
                         | PStr FastString
sof's avatar
sof committed
59 60

    The Chr and Str constructors are obvious enough.  The PStr constructor has a packed
61
    string (FastString) inside it.  It's generated by using the new "ptext" export.
sof's avatar
sof committed
62 63 64 65 66 67 68

    An advantage of this new setup is that you can get the renderer to do output
    directly (by passing in a function of type (TextDetails -> IO () -> IO ()),
    rather than producing a string that you then print.


Version 2.0     24 April 1997
sof's avatar
sof committed
69 70
  * Made empty into a left unit for <> as well as a right unit;
    it is also now true that
sof's avatar
sof committed
71
        nest k empty = empty
sof's avatar
sof committed
72 73 74 75 76 77 78 79 80 81 82
    which wasn't true before.

  * Fixed an obscure bug in sep that occassionally gave very wierd behaviour

  * Added $+$

  * Corrected and tidied up the laws and invariants

======================================================================
Relative to John's original paper, there are the following new features:

Ian Lynagh's avatar
Ian Lynagh committed
83
1.  There's an empty document, "empty".  It's a left and right unit for
sof's avatar
sof committed
84 85 86 87 88 89
    both <> and $$, and anywhere in the argument list for
    sep, hcat, hsep, vcat, fcat etc.

    It is Really Useful in practice.

2.  There is a paragraph-fill combinator, fsep, that's much like sep,
Michael D. Adams's avatar
Michael D. Adams committed
90
    only it keeps fitting things on one line until it can't fit any more.
sof's avatar
sof committed
91

Ian Lynagh's avatar
Ian Lynagh committed
92
3.  Some random useful extra combinators are provided.
sof's avatar
sof committed
93 94 95 96 97 98 99 100 101 102 103 104 105 106 107
        <+> puts its arguments beside each other with a space between them,
            unless either argument is empty in which case it returns the other


        hcat is a list version of <>
        hsep is a list version of <+>
        vcat is a list version of $$

        sep (separate) is either like hsep or like vcat, depending on what fits

        cat  is behaves like sep,  but it uses <> for horizontal conposition
        fcat is behaves like fsep, but it uses <> for horizontal conposition

        These new ones do the obvious things:
                char, semi, comma, colon, space,
Ian Lynagh's avatar
Ian Lynagh committed
108
                parens, brackets, braces,
sof's avatar
sof committed
109
                quotes, doubleQuotes
Ian Lynagh's avatar
Ian Lynagh committed
110

sof's avatar
sof committed
111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
4.      The "above" combinator, $$, now overlaps its two arguments if the
        last line of the top argument stops before the first line of the second begins.
        For example:  text "hi" $$ nest 5 "there"
        lays out as
                        hi   there
        rather than
                        hi
                             there

        There are two places this is really useful

        a) When making labelled blocks, like this:
                Left ->   code for left
                Right ->  code for right
                LongLongLongLabel ->
                          code for longlonglonglabel
           The block is on the same line as the label if the label is
           short, but on the next line otherwise.

        b) When laying out lists like this:
                [ first
                , second
                , third
                ]
           which some people like.  But if the list fits on one line
           you want [first, second, third].  You can't do this with
           John's original combinators, but it's quite easy with the
           new $$.

        The combinator $+$ gives the original "never-overlap" behaviour.

5.      Several different renderers are provided:
                * a standard one
Ian Lynagh's avatar
Ian Lynagh committed
144
                * one that uses cut-marks to avoid deeply-nested documents
sof's avatar
sof committed
145 146 147 148 149 150
                        simply piling up in the right-hand margin
                * one that ignores indentation (fewer chars output; good for machines)
                * one that ignores indentation and newlines (ditto, only more so)

6.      Numerous implementation tidy-ups
        Use of unboxed data types to speed up the implementation
sof's avatar
sof committed
151 152


153 154

\begin{code}
155
{-# LANGUAGE BangPatterns #-}
156 157 158 159
{-# OPTIONS -fno-warn-unused-imports #-}
-- XXX GHC 6.9 seems to be confused by unpackCString# being used only in
--     a RULE

160
module Pretty (
sof's avatar
sof committed
161 162 163 164 165
        Doc,            -- Abstract
        Mode(..), TextDetails(..),

        empty, isEmpty, nest,

166
        char, text, ftext, ptext, zeroWidthText,
sof's avatar
sof committed
167 168 169
        int, integer, float, double, rational,
        parens, brackets, braces, quotes, doubleQuotes,
        semi, comma, colon, space, equals,
mnislaih's avatar
mnislaih committed
170
        lparen, rparen, lbrack, rbrack, lbrace, rbrace, cparen,
sof's avatar
sof committed
171

Ian Lynagh's avatar
Ian Lynagh committed
172 173 174 175
        (<>), (<+>), hcat, hsep,
        ($$), ($+$), vcat,
        sep, cat,
        fsep, fcat,
sof's avatar
sof committed
176 177

        hang, punctuate,
Ian Lynagh's avatar
Ian Lynagh committed
178

sof's avatar
sof committed
179
--      renderStyle,            -- Haskell 1.3 only
180 181
        render, fullRender, printDoc, showDocWith,
        bufLeftRender -- performance hack
sof's avatar
sof committed
182 183
  ) where

184
import BufWrite
sof's avatar
sof committed
185
import FastString
186
import FastTypes
Ian Lynagh's avatar
Ian Lynagh committed
187
import Panic
benl's avatar
benl committed
188
import StaticFlags
189
import Numeric (fromRat)
Simon Marlow's avatar
Simon Marlow committed
190
import System.IO
191
--import Foreign.Ptr (castPtr)
192

193 194
#if defined(__GLASGOW_HASKELL__)
--for a RULES
Ian Lynagh's avatar
Ian Lynagh committed
195
import GHC.Base ( unpackCString# )
Ian Lynagh's avatar
Ian Lynagh committed
196
import GHC.Exts ( Int# )
Ian Lynagh's avatar
Ian Lynagh committed
197
import GHC.Ptr  ( Ptr(..) )
198
#endif
199

sof's avatar
sof committed
200
-- Don't import Util( assertPanic ) because it makes a loop in the module structure
sof's avatar
sof committed
201

Ian Lynagh's avatar
Ian Lynagh committed
202
infixl 6 <>
sof's avatar
sof committed
203 204 205
infixl 6 <+>
infixl 5 $$, $+$
\end{code}
206 207


sof's avatar
sof committed
208 209 210 211 212
\begin{code}

-- Disable ASSERT checks; they are expensive!
#define LOCAL_ASSERT(x)

213 214 215
\end{code}


Thomas Schilling's avatar
Thomas Schilling committed
216 217
%*********************************************************
%*                                                       *
sof's avatar
sof committed
218
\subsection{The interface}
Thomas Schilling's avatar
Thomas Schilling committed
219 220
%*                                                       *
%*********************************************************
sof's avatar
sof committed
221 222

The primitive @Doc@ values
223 224

\begin{code}
sof's avatar
sof committed
225 226
empty                     :: Doc
isEmpty                   :: Doc    -> Bool
227 228 229 230
-- | Some text, but without any width. Use for non-printing text
-- such as a HTML or Latex tags
zeroWidthText :: String   -> Doc

Ian Lynagh's avatar
Ian Lynagh committed
231
text                      :: String -> Doc
sof's avatar
sof committed
232
char                      :: Char -> Doc
sof's avatar
sof committed
233

sof's avatar
sof committed
234
semi, comma, colon, space, equals              :: Doc
sof's avatar
sof committed
235 236
lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc

Ian Lynagh's avatar
Ian Lynagh committed
237
parens, brackets, braces  :: Doc -> Doc
sof's avatar
sof committed
238
quotes, doubleQuotes      :: Doc -> Doc
sof's avatar
sof committed
239

sof's avatar
sof committed
240
int      :: Int -> Doc
sof's avatar
sof committed
241
integer  :: Integer -> Doc
sof's avatar
sof committed
242 243
float    :: Float -> Doc
double   :: Double -> Doc
sof's avatar
sof committed
244
rational :: Rational -> Doc
245 246
\end{code}

sof's avatar
sof committed
247
Combining @Doc@ values
248 249

\begin{code}
sof's avatar
sof committed
250 251 252 253
(<>)   :: Doc -> Doc -> Doc     -- Beside
hcat   :: [Doc] -> Doc          -- List version of <>
(<+>)  :: Doc -> Doc -> Doc     -- Beside, separated by space
hsep   :: [Doc] -> Doc          -- List version of <+>
254

sof's avatar
sof committed
255 256 257
($$)   :: Doc -> Doc -> Doc     -- Above; if there is no
                                -- overlap it "dovetails" the two
vcat   :: [Doc] -> Doc          -- List version of $$
258

sof's avatar
sof committed
259 260 261 262
cat    :: [Doc] -> Doc          -- Either hcat or vcat
sep    :: [Doc] -> Doc          -- Either hsep or vcat
fcat   :: [Doc] -> Doc          -- ``Paragraph fill'' version of cat
fsep   :: [Doc] -> Doc          -- ``Paragraph fill'' version of sep
263

sof's avatar
sof committed
264
nest   :: Int -> Doc -> Doc     -- Nested
sof's avatar
sof committed
265
\end{code}
266

sof's avatar
sof committed
267
GHC-specific ones.
268

sof's avatar
sof committed
269 270
\begin{code}
hang :: Doc -> Int -> Doc -> Doc
sof's avatar
sof committed
271
punctuate :: Doc -> [Doc] -> [Doc]      -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
sof's avatar
sof committed
272
\end{code}
273

Ian Lynagh's avatar
Ian Lynagh committed
274
Displaying @Doc@ values.
275

sof's avatar
sof committed
276
\begin{code}
277
instance Show Doc where
Ian Lynagh's avatar
Ian Lynagh committed
278
  showsPrec _ doc cont = showDoc doc cont
sof's avatar
sof committed
279

sof's avatar
sof committed
280
render     :: Doc -> String             -- Uses default style
sof's avatar
sof committed
281
fullRender :: Mode
sof's avatar
sof committed
282 283 284 285 286 287 288
           -> Int                       -- Line length
           -> Float                     -- Ribbons per line
           -> (TextDetails -> a -> a)   -- What to do with text
           -> a                         -- What to do at the end
           -> Doc
           -> a                         -- Result

Ian Lynagh's avatar
Ian Lynagh committed
289
{-      When we start using 1.3
sof's avatar
sof committed
290
renderStyle  :: Style -> Doc -> String
sof's avatar
sof committed
291 292 293 294 295
data Style = Style { lineLength     :: Int,     -- In chars
                     ribbonsPerLine :: Float,   -- Ratio of ribbon length to line length
                     mode :: Mode
             }
style :: Style          -- The default style
sof's avatar
sof committed
296 297 298
style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
-}

Ian Lynagh's avatar
Ian Lynagh committed
299
data Mode = PageMode            -- Normal
sof's avatar
sof committed
300 301 302
          | ZigZagMode          -- With zig-zag cuts
          | LeftMode            -- No indentation, infinitely long lines
          | OneLineMode         -- All on one line
303 304 305

\end{code}

sof's avatar
sof committed
306

Thomas Schilling's avatar
Thomas Schilling committed
307 308
%*********************************************************
%*                                                       *
sof's avatar
sof committed
309
\subsection{The @Doc@ calculus}
Thomas Schilling's avatar
Thomas Schilling committed
310 311
%*                                                       *
%*********************************************************
sof's avatar
sof committed
312 313 314 315 316

The @Doc@ combinators satisfy the following laws:
\begin{verbatim}
Laws for $$
~~~~~~~~~~~
sof's avatar
sof committed
317 318 319
<a1>    (x $$ y) $$ z   = x $$ (y $$ z)
<a2>    empty $$ x      = x
<a3>    x $$ empty      = x
sof's avatar
sof committed
320

sof's avatar
sof committed
321
        ...ditto $+$...
sof's avatar
sof committed
322 323 324

Laws for <>
~~~~~~~~~~~
sof's avatar
sof committed
325 326 327
<b1>    (x <> y) <> z   = x <> (y <> z)
<b2>    empty <> x      = empty
<b3>    x <> empty      = x
sof's avatar
sof committed
328

sof's avatar
sof committed
329
        ...ditto <+>...
sof's avatar
sof committed
330 331 332

Laws for text
~~~~~~~~~~~~~
sof's avatar
sof committed
333 334
<t1>    text s <> text t        = text (s++t)
<t2>    text "" <> x            = x, if x non-empty
sof's avatar
sof committed
335 336 337

Laws for nest
~~~~~~~~~~~~~
sof's avatar
sof committed
338 339 340 341 342 343
<n1>    nest 0 x                = x
<n2>    nest k (nest k' x)      = nest (k+k') x
<n3>    nest k (x <> y)         = nest k z <> nest k y
<n4>    nest k (x $$ y)         = nest k x $$ nest k y
<n5>    nest k empty            = empty
<n6>    x <> nest k y           = x <> y, if x non-empty
sof's avatar
sof committed
344

Thomas Schilling's avatar
Thomas Schilling committed
345 346
 - Note the side condition on <n6>!  It is this that
   makes it OK for empty to be a left unit for <>.
sof's avatar
sof committed
347 348 349

Miscellaneous
~~~~~~~~~~~~~
Ian Lynagh's avatar
Ian Lynagh committed
350
<m1>    (text s <> x) $$ y = text s <> ((text "" <> x)) $$
sof's avatar
sof committed
351
                                         nest (-length s) y)
sof's avatar
sof committed
352

sof's avatar
sof committed
353 354
<m2>    (x $$ y) <> z = x $$ (y <> z)
        if y non-empty
sof's avatar
sof committed
355 356 357 358


Laws for list versions
~~~~~~~~~~~~~~~~~~~~~~
sof's avatar
sof committed
359 360
<l1>    sep (ps++[empty]++qs)   = sep (ps ++ qs)
        ...ditto hsep, hcat, vcat, fill...
sof's avatar
sof committed
361

sof's avatar
sof committed
362 363
<l2>    nest k (sep ps) = sep (map (nest k) ps)
        ...ditto hsep, hcat, vcat, fill...
sof's avatar
sof committed
364 365 366

Laws for oneLiner
~~~~~~~~~~~~~~~~~
sof's avatar
sof committed
367
<o1>    oneLiner (nest k p) = nest k (oneLiner p)
Ian Lynagh's avatar
Ian Lynagh committed
368
<o2>    oneLiner (x <> y)   = oneLiner x <> oneLiner y
sof's avatar
sof committed
369 370 371 372 373 374
\end{verbatim}


You might think that the following verion of <m1> would
be neater:
\begin{verbatim}
Ian Lynagh's avatar
Ian Lynagh committed
375
<3 NO>  (text s <> x) $$ y = text s <> ((empty <> x)) $$
sof's avatar
sof committed
376
                                         nest (-length s) y)
sof's avatar
sof committed
377 378 379
\end{verbatim}
But it doesn't work, for if x=empty, we would have
\begin{verbatim}
sof's avatar
sof committed
380 381
        text s $$ y = text s <> (empty $$ nest (-length s) y)
                    = text s <> nest (-length s) y
sof's avatar
sof committed
382 383 384 385
\end{verbatim}



Thomas Schilling's avatar
Thomas Schilling committed
386 387
%*********************************************************
%*                                                       *
sof's avatar
sof committed
388
\subsection{Simple derived definitions}
Thomas Schilling's avatar
Thomas Schilling committed
389 390
%*                                                       *
%*********************************************************
391 392

\begin{code}
sof's avatar
sof committed
393 394 395 396 397 398 399 400 401 402 403 404
semi  = char ';'
colon = char ':'
comma = char ','
space = char ' '
equals = char '='
lparen = char '('
rparen = char ')'
lbrack = char '['
rbrack = char ']'
lbrace = char '{'
rbrace = char '}'

sof's avatar
sof committed
405
int      n = text (show n)
sof's avatar
sof committed
406 407 408
integer  n = text (show n)
float    n = text (show n)
double   n = text (show n)
409
rational n = text (show (fromRat n :: Double))
sof's avatar
sof committed
410
--rational n = text (show (fromRationalX n)) -- _showRational 30 n)
sof's avatar
sof committed
411

sof's avatar
sof committed
412 413 414 415 416
quotes p        = char '`' <> p <> char '\''
doubleQuotes p  = char '"' <> p <> char '"'
parens p        = char '(' <> p <> char ')'
brackets p      = char '[' <> p <> char ']'
braces p        = char '{' <> p <> char '}'
sof's avatar
sof committed
417

Ian Lynagh's avatar
Ian Lynagh committed
418
cparen :: Bool -> Doc -> Doc
mnislaih's avatar
mnislaih committed
419 420
cparen True  = parens
cparen False = id
sof's avatar
sof committed
421 422 423 424 425

hcat = foldr (<>)  empty
hsep = foldr (<+>) empty
vcat = foldr ($$)  empty

426
hang d1 n d2 = sep [d1, nest n d2]
sof's avatar
sof committed
427

Ian Lynagh's avatar
Ian Lynagh committed
428
punctuate _ []     = []
sof's avatar
sof committed
429
punctuate p (d:ds) = go d ds
sof's avatar
sof committed
430 431 432
                   where
                     go d [] = [d]
                     go d (e:es) = (d <> p) : go e es
433 434 435
\end{code}


Thomas Schilling's avatar
Thomas Schilling committed
436 437
%*********************************************************
%*                                                       *
sof's avatar
sof committed
438
\subsection{The @Doc@ data type}
Thomas Schilling's avatar
Thomas Schilling committed
439 440
%*                                                       *
%*********************************************************
sof's avatar
sof committed
441 442 443

A @Doc@ represents a {\em set} of layouts.  A @Doc@ with
no occurrences of @Union@ or @NoDoc@ represents just one layout.
444
\begin{code}
sof's avatar
sof committed
445
data Doc
sof's avatar
sof committed
446 447
 = Empty                                -- empty
 | NilAbove Doc                         -- text "" $$ x
Ian Lynagh's avatar
Ian Lynagh committed
448
 | TextBeside !TextDetails FastInt Doc       -- text s <> x
449
 | Nest FastInt Doc                         -- nest k x
sof's avatar
sof committed
450 451 452 453
 | Union Doc Doc                        -- ul `union` ur
 | NoDoc                                -- The empty set of documents
 | Beside Doc Bool Doc                  -- True <=> space between
 | Above  Doc Bool Doc                  -- True <=> never overlap
sof's avatar
sof committed
454

sof's avatar
sof committed
455
type RDoc = Doc         -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
sof's avatar
sof committed
456 457 458 459 460


reduceDoc :: Doc -> RDoc
reduceDoc (Beside p g q) = beside p g (reduceDoc q)
reduceDoc (Above  p g q) = above  p g (reduceDoc q)
sof's avatar
sof committed
461
reduceDoc p              = p
sof's avatar
sof committed
462 463


464
data TextDetails = Chr  {-#UNPACK#-}!Char
sof's avatar
sof committed
465
                 | Str  String
Ian Lynagh's avatar
Ian Lynagh committed
466 467 468
                 | PStr FastString                      -- a hashed string
                 | LStr {-#UNPACK#-}!LitString FastInt  -- a '\0'-terminated
                                                        -- array of bytes
469

Ian Lynagh's avatar
Ian Lynagh committed
470
space_text :: TextDetails
sof's avatar
sof committed
471
space_text = Chr ' '
Ian Lynagh's avatar
Ian Lynagh committed
472
nl_text :: TextDetails
sof's avatar
sof committed
473
nl_text    = Chr '\n'
474 475
\end{code}

sof's avatar
sof committed
476 477 478 479 480 481 482 483 484
Here are the invariants:
\begin{itemize}
\item
The argument of @NilAbove@ is never @Empty@. Therefore
a @NilAbove@ occupies at least two lines.

\item
The arugment of @TextBeside@ is never @Nest@.

Ian Lynagh's avatar
Ian Lynagh committed
485
\item
sof's avatar
sof committed
486 487
The layouts of the two arguments of @Union@ both flatten to the same string.

Ian Lynagh's avatar
Ian Lynagh committed
488
\item
sof's avatar
sof committed
489 490 491 492 493 494 495
The arguments of @Union@ are either @TextBeside@, or @NilAbove@.

\item
The right argument of a union cannot be equivalent to the empty set (@NoDoc@).
If the left argument of a union is equivalent to the empty set (@NoDoc@),
then the @NoDoc@ appears in the first line.

Ian Lynagh's avatar
Ian Lynagh committed
496
\item
sof's avatar
sof committed
497 498 499
An empty document is always represented by @Empty@.
It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.

Ian Lynagh's avatar
Ian Lynagh committed
500
\item
sof's avatar
sof committed
501 502 503 504 505 506 507 508
The first line of every layout in the left argument of @Union@
is longer than the first line of any layout in the right argument.
(1) ensures that the left argument has a first line.  In view of (3),
this invariant means that the right argument must have at least two
lines.
\end{itemize}

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
509 510 511
-- Arg of a NilAbove is always an RDoc
nilAbove_ :: Doc -> Doc
nilAbove_ p = LOCAL_ASSERT( _ok p ) NilAbove p
sof's avatar
sof committed
512
            where
Ian Lynagh's avatar
Ian Lynagh committed
513 514
              _ok Empty = False
              _ok _     = True
sof's avatar
sof committed
515

Ian Lynagh's avatar
Ian Lynagh committed
516 517 518
-- Arg of a TextBeside is always an RDoc
textBeside_ :: TextDetails -> FastInt -> Doc -> Doc
textBeside_ s sl p = TextBeside s sl (LOCAL_ASSERT( _ok p ) p)
sof's avatar
sof committed
519
                   where
Ian Lynagh's avatar
Ian Lynagh committed
520 521
                     _ok (Nest _ _) = False
                     _ok _          = True
sof's avatar
sof committed
522

Ian Lynagh's avatar
Ian Lynagh committed
523 524 525
-- Arg of Nest is always an RDoc
nest_ :: FastInt -> Doc -> Doc
nest_ k p = Nest k (LOCAL_ASSERT( _ok p ) p)
sof's avatar
sof committed
526
          where
Ian Lynagh's avatar
Ian Lynagh committed
527 528
            _ok Empty = False
            _ok _     = True
sof's avatar
sof committed
529

Ian Lynagh's avatar
Ian Lynagh committed
530 531 532
-- Args of union are always RDocs
union_ :: Doc -> Doc -> Doc
union_ p q = Union (LOCAL_ASSERT( _ok p ) p) (LOCAL_ASSERT( _ok q ) q)
sof's avatar
sof committed
533
           where
Ian Lynagh's avatar
Ian Lynagh committed
534 535 536 537
             _ok (TextBeside _ _ _) = True
             _ok (NilAbove _)       = True
             _ok (Union _ _)        = True
             _ok _                  = False
sof's avatar
sof committed
538 539 540
\end{code}

Notice the difference between
sof's avatar
sof committed
541 542 543 544
        * NoDoc (no documents)
        * Empty (one empty document; no height and no width)
        * text "" (a document containing the empty string;
                   one line high, but has no width)
sof's avatar
sof committed
545 546 547



Thomas Schilling's avatar
Thomas Schilling committed
548 549
%*********************************************************
%*                                                       *
sof's avatar
sof committed
550
\subsection{@empty@, @text@, @nest@, @union@}
Thomas Schilling's avatar
Thomas Schilling committed
551 552
%*                                                       *
%*********************************************************
553 554

\begin{code}
sof's avatar
sof committed
555 556
empty = Empty

sof's avatar
sof committed
557 558 559
isEmpty Empty = True
isEmpty _     = False

560 561
char  c = textBeside_ (Chr c) (_ILIT(1)) Empty
text  s = case iUnbox (length   s) of {sl -> textBeside_ (Str s)  sl Empty}
Ian Lynagh's avatar
Ian Lynagh committed
562
ftext :: FastString -> Doc
563
ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty}
Ian Lynagh's avatar
Ian Lynagh committed
564
ptext :: LitString -> Doc
565
ptext s_= case iUnbox (lengthLS s) of {sl -> textBeside_ (LStr s sl) sl Empty}
566
  where s = {-castPtr-} s_
567
zeroWidthText s = textBeside_ (Str s) (_ILIT(0)) Empty
sof's avatar
sof committed
568

569
#if defined(__GLASGOW_HASKELL__)
570 571
-- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
-- intermediate packing/unpacking of the string.
Ian Lynagh's avatar
Ian Lynagh committed
572
{-# RULES
573
  "text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
574
 #-}
575
#endif
576

577
nest k  p = mkNest (iUnbox k) (reduceDoc p)        -- Externally callable version
sof's avatar
sof committed
578 579

-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
Ian Lynagh's avatar
Ian Lynagh committed
580
mkNest :: Int# -> Doc -> Doc
581
mkNest k       (Nest k1 p) = mkNest (k +# k1) p
Ian Lynagh's avatar
Ian Lynagh committed
582 583
mkNest _       NoDoc       = NoDoc
mkNest _       Empty       = Empty
584
mkNest k       p  | k ==# _ILIT(0)  = p       -- Worth a try!
sof's avatar
sof committed
585
mkNest k       p           = nest_ k p
sof's avatar
sof committed
586 587

-- mkUnion checks for an empty document
Ian Lynagh's avatar
Ian Lynagh committed
588 589
mkUnion :: Doc -> Doc -> Doc
mkUnion Empty _ = Empty
sof's avatar
sof committed
590
mkUnion p q     = p `union_` q
591 592
\end{code}

Thomas Schilling's avatar
Thomas Schilling committed
593 594
%*********************************************************
%*                                                       *
sof's avatar
sof committed
595
\subsection{Vertical composition @$$@}
Thomas Schilling's avatar
Thomas Schilling committed
596 597
%*                                                       *
%*********************************************************
sof's avatar
sof committed
598

599 600

\begin{code}
sof's avatar
sof committed
601
p $$  q = Above p False q
Ian Lynagh's avatar
Ian Lynagh committed
602
($+$) :: Doc -> Doc -> Doc
sof's avatar
sof committed
603 604 605 606
p $+$ q = Above p True q

above :: Doc -> Bool -> RDoc -> RDoc
above (Above p g1 q1)  g2 q2 = above p g1 (above q1 g2 q2)
607 608
above p@(Beside _ _ _) g  q  = aboveNest (reduceDoc p) g (_ILIT(0)) (reduceDoc q)
above p g q                  = aboveNest p             g (_ILIT(0)) (reduceDoc q)
sof's avatar
sof committed
609

610
aboveNest :: RDoc -> Bool -> FastInt -> RDoc -> RDoc
sof's avatar
sof committed
611 612
-- Specfication: aboveNest p g k q = p $g$ (nest k q)

Ian Lynagh's avatar
Ian Lynagh committed
613
aboveNest NoDoc               _ _ _ = NoDoc
Ian Lynagh's avatar
Ian Lynagh committed
614
aboveNest (p1 `Union` p2)     g k q = aboveNest p1 g k q `union_`
sof's avatar
sof committed
615
                                      aboveNest p2 g k q
Ian Lynagh's avatar
Ian Lynagh committed
616

Ian Lynagh's avatar
Ian Lynagh committed
617
aboveNest Empty               _ k q = mkNest k q
618
aboveNest (Nest k1 p)         g k q = nest_ k1 (aboveNest p g (k -# k1) q)
sof's avatar
sof committed
619
                                  -- p can't be Empty, so no need for mkNest
Ian Lynagh's avatar
Ian Lynagh committed
620

sof's avatar
sof committed
621 622
aboveNest (NilAbove p)        g k q = nilAbove_ (aboveNest p g k q)
aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
sof's avatar
sof committed
623
                                    where
624
                                      !k1  = k -# sl
sof's avatar
sof committed
625 626
                                      rest = case p of
                                                Empty -> nilAboveNest g k1 q
Ian Lynagh's avatar
Ian Lynagh committed
627 628
                                                _     -> aboveNest  p g k1 q
aboveNest _                   _ _ _ = panic "aboveNest: Unhandled case"
629 630 631
\end{code}

\begin{code}
632
nilAboveNest :: Bool -> FastInt -> RDoc -> RDoc
Ian Lynagh's avatar
Ian Lynagh committed
633
-- Specification: text s <> nilaboveNest g k q
sof's avatar
sof committed
634
--              = text s <> (text "" $g$ nest k q)
sof's avatar
sof committed
635

Ian Lynagh's avatar
Ian Lynagh committed
636
nilAboveNest _ _ Empty       = Empty    -- Here's why the "text s <>" is in the spec!
637
nilAboveNest g k (Nest k1 q) = nilAboveNest g (k +# k1) q
sof's avatar
sof committed
638

639
nilAboveNest g k q           | (not g) && (k ># _ILIT(0))        -- No newline if no overlap
sof's avatar
sof committed
640 641 642
                             = textBeside_ (Str (spaces k)) k q
                             | otherwise                        -- Put them really above
                             = nilAbove_ (mkNest k q)
sof's avatar
sof committed
643 644 645
\end{code}


Thomas Schilling's avatar
Thomas Schilling committed
646 647
%*********************************************************
%*                                                       *
sof's avatar
sof committed
648
\subsection{Horizontal composition @<>@}
Thomas Schilling's avatar
Thomas Schilling committed
649 650
%*                                                       *
%*********************************************************
sof's avatar
sof committed
651 652 653 654 655 656 657

\begin{code}
p <>  q = Beside p False q
p <+> q = Beside p True  q

beside :: Doc -> Bool -> RDoc -> RDoc
-- Specification: beside g p q = p <g> q
Ian Lynagh's avatar
Ian Lynagh committed
658

Ian Lynagh's avatar
Ian Lynagh committed
659
beside NoDoc               _ _   = NoDoc
sof's avatar
sof committed
660
beside (p1 `Union` p2)     g q   = (beside p1 g q) `union_` (beside p2 g q)
Ian Lynagh's avatar
Ian Lynagh committed
661
beside Empty               _ q   = q
662
beside (Nest k p)          g q   = nest_ k $! beside p g q       -- p non-empty
Ian Lynagh's avatar
Ian Lynagh committed
663 664
beside p@(Beside p1 g1 q1) g2 q2
           {- (A `op1` B) `op2` C == A `op1` (B `op2` C)  iff op1 == op2
sof's avatar
sof committed
665
                                                 [ && (op1 == <> || op1 == <+>) ] -}
666
         | g1 == g2              = beside p1 g1 $! beside q1 g2 q2
sof's avatar
sof committed
667
         | otherwise             = beside (reduceDoc p) g2 q2
668 669 670
beside p@(Above _ _ _)     g q   = let d = reduceDoc p in d `seq` beside d g q
beside (NilAbove p)        g q   = nilAbove_ $! beside p g q
beside (TextBeside s sl p) g q   = textBeside_ s sl $! rest
sof's avatar
sof committed
671 672 673
                               where
                                  rest = case p of
                                           Empty -> nilBeside g q
Ian Lynagh's avatar
Ian Lynagh committed
674
                                           _     -> beside p g q
675 676 677
\end{code}

\begin{code}
sof's avatar
sof committed
678
nilBeside :: Bool -> RDoc -> RDoc
Ian Lynagh's avatar
Ian Lynagh committed
679
-- Specification: text "" <> nilBeside g p
sof's avatar
sof committed
680
--              = text "" <g> p
sof's avatar
sof committed
681

Ian Lynagh's avatar
Ian Lynagh committed
682
nilBeside _ Empty      = Empty  -- Hence the text "" in the spec
sof's avatar
sof committed
683
nilBeside g (Nest _ p) = nilBeside g p
684
nilBeside g p          | g         = textBeside_ space_text (_ILIT(1)) p
sof's avatar
sof committed
685
                       | otherwise = p
686 687
\end{code}

Thomas Schilling's avatar
Thomas Schilling committed
688 689
%*********************************************************
%*                                                       *
sof's avatar
sof committed
690
\subsection{Separate, @sep@, Hughes version}
Thomas Schilling's avatar
Thomas Schilling committed
691 692
%*                                                       *
%*********************************************************
693 694

\begin{code}
sof's avatar
sof committed
695
-- Specification: sep ps  = oneLiner (hsep ps)
sof's avatar
sof committed
696 697
--                         `union`
--                          vcat ps
sof's avatar
sof committed
698

sof's avatar
sof committed
699 700
sep = sepX True         -- Separate with spaces
cat = sepX False        -- Don't
sof's avatar
sof committed
701

Ian Lynagh's avatar
Ian Lynagh committed
702 703
sepX :: Bool -> [Doc] -> Doc
sepX _ []     = empty
704
sepX x (p:ps) = sep1 x (reduceDoc p) (_ILIT(0)) ps
sof's avatar
sof committed
705 706 707


-- Specification: sep1 g k ys = sep (x : map (nest k) ys)
sof's avatar
sof committed
708 709
--                            = oneLiner (x <g> nest k (hsep ys))
--                              `union` x $$ nest k (vcat ys)
sof's avatar
sof committed
710

711
sep1 :: Bool -> RDoc -> FastInt -> [Doc] -> RDoc
Ian Lynagh's avatar
Ian Lynagh committed
712
sep1 _ NoDoc               _ _  = NoDoc
sof's avatar
sof committed
713
sep1 g (p `Union` q)       k ys = sep1 g p k ys
sof's avatar
sof committed
714 715
                                  `union_`
                                  (aboveNest q False k (reduceDoc (vcat ys)))
sof's avatar
sof committed
716 717

sep1 g Empty               k ys = mkNest k (sepX g ys)
718
sep1 g (Nest n p)          k ys = nest_ n (sep1 g p (k -# n) ys)
sof's avatar
sof committed
719

Ian Lynagh's avatar
Ian Lynagh committed
720
sep1 _ (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
721
sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k -# sl) ys)
Ian Lynagh's avatar
Ian Lynagh committed
722
sep1 _ _                   _ _  = panic "sep1: Unhandled case"
sof's avatar
sof committed
723 724 725 726 727

-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
-- Called when we have already found some text in the first item
-- We have to eat up nests

Ian Lynagh's avatar
Ian Lynagh committed
728
sepNB :: Bool -> Doc -> FastInt -> [Doc] -> Doc
sof's avatar
sof committed
729 730 731
sepNB g (Nest _ p)  k ys  = sepNB g p k ys

sepNB g Empty k ys        = oneLiner (nilBeside g (reduceDoc rest))
Ian Lynagh's avatar
Ian Lynagh committed
732
                                `mkUnion`
sof's avatar
sof committed
733 734 735 736
                            nilAboveNest False k (reduceDoc (vcat ys))
                          where
                            rest | g         = hsep ys
                                 | otherwise = hcat ys
sof's avatar
sof committed
737

sof's avatar
sof committed
738
sepNB g p k ys            = sep1 g p k ys
739 740
\end{code}

Thomas Schilling's avatar
Thomas Schilling committed
741 742
%*********************************************************
%*                                                       *
sof's avatar
sof committed
743
\subsection{@fill@}
Thomas Schilling's avatar
Thomas Schilling committed
744 745
%*                                                       *
%*********************************************************
sof's avatar
sof committed
746

747
\begin{code}
sof's avatar
sof committed
748 749 750
fsep = fill True
fcat = fill False

Ian Lynagh's avatar
Ian Lynagh committed
751
-- Specification:
sof's avatar
sof committed
752 753
--   fill []  = empty
--   fill [p] = p
Ian Lynagh's avatar
Ian Lynagh committed
754
--   fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
sof's avatar
sof committed
755 756 757
--                                          (fill (oneLiner p2 : ps))
--                     `union`
--                      p1 $$ fill ps
sof's avatar
sof committed
758

Ian Lynagh's avatar
Ian Lynagh committed
759 760
fill :: Bool -> [Doc] -> Doc
fill _ []     = empty
761
fill g (p:ps) = fill1 g (reduceDoc p) (_ILIT(0)) ps
sof's avatar
sof committed
762 763


764
fill1 :: Bool -> RDoc -> FastInt -> [Doc] -> Doc
Ian Lynagh's avatar
Ian Lynagh committed
765
fill1 _ NoDoc               _ _  = NoDoc
sof's avatar
sof committed
766
fill1 g (p `Union` q)       k ys = fill1 g p k ys
sof's avatar
sof committed
767 768
                                   `union_`
                                   (aboveNest q False k (fill g ys))
sof's avatar
sof committed
769 770

fill1 g Empty               k ys = mkNest k (fill g ys)
771
fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k -# n) ys)
sof's avatar
sof committed
772 773

fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fill g ys))
774
fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k -# sl) ys)
Ian Lynagh's avatar
Ian Lynagh committed
775
fill1 _ _                   _ _  = panic "fill1: Unhandled case"
sof's avatar
sof committed
776

Ian Lynagh's avatar
Ian Lynagh committed
777
fillNB :: Bool -> Doc -> Int# -> [Doc] -> Doc
sof's avatar
sof committed
778
fillNB g (Nest _ p)  k ys  = fillNB g p k ys
Ian Lynagh's avatar
Ian Lynagh committed
779
fillNB _ Empty _ []        = Empty
sof's avatar
sof committed
780
fillNB g Empty k (y:ys)    = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
Ian Lynagh's avatar
Ian Lynagh committed
781
                             `mkUnion`
sof's avatar
sof committed
782 783
                             nilAboveNest False k (fill g (y:ys))
                           where
784 785
                             !k1 | g         = k -# _ILIT(1)
                                 | otherwise = k
sof's avatar
sof committed
786

sof's avatar
sof committed
787
fillNB g p k ys            = fill1 g p k ys
788 789
\end{code}

790

Thomas Schilling's avatar
Thomas Schilling committed
791 792
%*********************************************************
%*                                                       *
sof's avatar
sof committed
793
\subsection{Selecting the best layout}
Thomas Schilling's avatar
Thomas Schilling committed
794 795
%*                                                       *
%*********************************************************
796 797

\begin{code}
798
best :: Int             -- Line length
sof's avatar
sof committed
799
     -> Int             -- Ribbon length
sof's avatar
sof committed
800
     -> RDoc
sof's avatar
sof committed
801
     -> RDoc            -- No unions in here!
sof's avatar
sof committed
802

803 804
best w_ r_ p
  = get (iUnbox w_) p
sof's avatar
sof committed
805
  where
806
    !r = iUnbox r_
807
    get :: FastInt          -- (Remaining) width of line
sof's avatar
sof committed
808
        -> Doc -> Doc
Ian Lynagh's avatar
Ian Lynagh committed
809 810
    get _ Empty               = Empty
    get _ NoDoc               = NoDoc
sof's avatar
sof committed
811 812
    get w (NilAbove p)        = nilAbove_ (get w p)
    get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
813
    get w (Nest k p)          = nest_ k (get (w -# k) p)
sof's avatar
sof committed
814
    get w (p `Union` q)       = nicest w r (get w p) (get w q)
Ian Lynagh's avatar
Ian Lynagh committed
815
    get _ _                   = panic "best/get: Unhandled case"
sof's avatar
sof committed
816

817 818
    get1 :: FastInt         -- (Remaining) width of line
         -> FastInt         -- Amount of first line already eaten up
sof's avatar
sof committed
819 820
         -> Doc         -- This is an argument to TextBeside => eat Nests
         -> Doc         -- No unions in here!
sof's avatar
sof committed
821

Ian Lynagh's avatar
Ian Lynagh committed
822 823
    get1 _ _  Empty               = Empty
    get1 _ _  NoDoc               = NoDoc
824 825
    get1 w sl (NilAbove p)        = nilAbove_ (get (w -# sl) p)
    get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl +# tl) p)
Ian Lynagh's avatar
Ian Lynagh committed
826
    get1 w sl (Nest _ p)          = get1 w sl p
Ian Lynagh's avatar
Ian Lynagh committed
827
    get1 w sl (p `Union` q)       = nicest1 w r sl (get1 w sl p)
sof's avatar
sof committed
828
                                                   (get1 w sl q)
Ian Lynagh's avatar
Ian Lynagh committed
829
    get1 _ _  _                   = panic "best/get1: Unhandled case"
sof's avatar
sof committed
830

Ian Lynagh's avatar
Ian Lynagh committed
831
nicest :: FastInt -> FastInt -> Doc -> Doc -> Doc
832
nicest w r p q = nicest1 w r (_ILIT(0)) p q
Ian Lynagh's avatar
Ian Lynagh committed
833
nicest1 :: FastInt -> FastInt -> Int# -> Doc -> Doc -> Doc
834
nicest1 w r sl p q | fits ((w `minFastInt` r) -# sl) p = p
sof's avatar
sof committed
835
                   | otherwise                   = q
sof's avatar
sof committed
836

837
fits :: FastInt     -- Space available
sof's avatar
sof committed
838
     -> Doc
sof's avatar
sof committed
839
     -> Bool    -- True if *first line* of Doc fits in space available
Ian Lynagh's avatar
Ian Lynagh committed
840

Ian Lynagh's avatar
Ian Lynagh committed
841 842 843 844
fits n _   | n <# _ILIT(0) = False
fits _ NoDoc               = False
fits _ Empty               = True
fits _ (NilAbove _)        = True
845
fits n (TextBeside _ sl p) = fits (n -# sl) p
Ian Lynagh's avatar
Ian Lynagh committed
846
fits _ _                   = panic "fits: Unhandled case"
sof's avatar
sof committed
847 848 849 850
\end{code}

@first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
@first@ returns its first argument if it is non-empty, otherwise its second.
851

sof's avatar
sof committed
852
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
853
first :: Doc -> Doc -> Doc
Ian Lynagh's avatar
Ian Lynagh committed
854
first p q | nonEmptySet p = p
sof's avatar
sof committed
855
          | otherwise     = q
sof's avatar
sof committed
856

Ian Lynagh's avatar
Ian Lynagh committed
857
nonEmptySet :: Doc -> Bool
858
nonEmptySet NoDoc              = False
Ian Lynagh's avatar
Ian Lynagh committed
859
nonEmptySet (_ `Union` _)      = True
sof's avatar
sof committed
860
nonEmptySet Empty              = True
Ian Lynagh's avatar
Ian Lynagh committed
861
nonEmptySet (NilAbove _)       = True           -- NoDoc always in first line
sof's avatar
sof committed
862 863
nonEmptySet (TextBeside _ _ p) = nonEmptySet p
nonEmptySet (Nest _ p)         = nonEmptySet p
Ian Lynagh's avatar
Ian Lynagh committed
864
nonEmptySet _                  = panic "nonEmptySet: Unhandled case"
sof's avatar
sof committed
865 866 867 868 869 870 871 872
\end{code}

@oneLiner@ returns the one-line members of the given set of @Doc@s.

\begin{code}
oneLiner :: Doc -> Doc
oneLiner NoDoc               = NoDoc
oneLiner Empty               = Empty
Ian Lynagh's avatar
Ian Lynagh committed
873
oneLiner (NilAbove _)        = NoDoc
sof's avatar
sof committed
874 875
oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
oneLiner (Nest k p)          = nest_ k (oneLiner p)