Pretty.lhs 35.6 KB
Newer Older
sof's avatar
sof committed
1
*********************************************************************************
sof's avatar
sof committed
2
3
4
5
6
7
8
9
10
11
*                                                                               *
*       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
12
13
*********************************************************************************

sof's avatar
sof committed
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
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
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.
 
    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:
 
         <> = Beside
         $$ = Above
 
    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
83
84
85
86
87
88
89
90
91
92
    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:

1.  There's an empty document, "empty".  It's a left and right unit for 
    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,
    only it keeps fitting things on one line until itc can't fit any more.

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
108
109
110
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
144
145
146
147
148
149
150
        <+> 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,
                parens, brackets, braces, 
                quotes, doubleQuotes
        
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
                * one that uses cut-marks to avoid deeply-nested documents 
                        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
155

\begin{code}
module Pretty (
sof's avatar
sof committed
156
157
158
159
160
        Doc,            -- Abstract
        Mode(..), TextDetails(..),

        empty, isEmpty, nest,

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

        (<>), (<+>), hcat, hsep, 
        ($$), ($+$), vcat, 
        sep, cat, 
        fsep, fcat, 

        hang, punctuate,
        
--      renderStyle,            -- Haskell 1.3 only
175
        render, fullRender, printDoc, showDocWith
sof's avatar
sof committed
176
177
178
179
  ) where

#include "HsVersions.h"

180
import BufWrite
sof's avatar
sof committed
181
import FastString
182

Simon Marlow's avatar
Simon Marlow committed
183
import GHC.Exts
184
185

import Numeric (fromRat)
Simon Marlow's avatar
Simon Marlow committed
186
import System.IO
187

188
import GHC.Base		( unpackCString# )
189
import GHC.Ptr		( Ptr(..) )
190

sof's avatar
sof committed
191
-- Don't import Util( assertPanic ) because it makes a loop in the module structure
sof's avatar
sof committed
192
193
194
195
196

infixl 6 <> 
infixl 6 <+>
infixl 5 $$, $+$
\end{code}
197
198


199

sof's avatar
sof committed
200
*********************************************************
sof's avatar
sof committed
201
*                                                       *
sof's avatar
sof committed
202
\subsection{CPP magic so that we can compile with both GHC and Hugs}
sof's avatar
sof committed
203
*                                                       *
sof's avatar
sof committed
204
205
206
207
*********************************************************

The library uses unboxed types to get a bit more speed, but these CPP macros
allow you to use either GHC or Hugs.  To get GHC, just set the CPP variable
sof's avatar
sof committed
208
        __GLASGOW_HASKELL__
sof's avatar
sof committed
209
210
211
212
213
214
215
216
217
218

\begin{code}

#if defined(__GLASGOW_HASKELL__)

-- Glasgow Haskell

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

219
220
#define ILIT(x) (x#)
#define IBOX(x) (I# (x))
sof's avatar
sof committed
221
222
#define INT     Int#
#define MINUS   -#
sof's avatar
sof committed
223
#define NEGATE  negateInt#
sof's avatar
sof committed
224
225
226
227
#define PLUS    +#
#define GR      >#
#define GREQ    >=#
#define LT      <#
228
#define LTEQ    <=#
sof's avatar
sof committed
229
#define DIV     `quotInt#`
sof's avatar
sof committed
230
231


sof's avatar
sof committed
232
233
#define SHOW    Show
#define MAXINT  maxBound
234

sof's avatar
sof committed
235
236
237
238
239
240
#else

-- Standard Haskell

#define LOCAL_ASSERT(x)

sof's avatar
sof committed
241
242
243
#define INT     Int
#define IBOX(x) x
#define MINUS   -
sof's avatar
sof committed
244
#define NEGATE  negate
sof's avatar
sof committed
245
246
247
248
249
#define PLUS    +
#define GR      >
#define GREQ    >=
#define LT      <
#define DIV     `quot`
sof's avatar
sof committed
250
251
#define ILIT(x) x

sof's avatar
sof committed
252
253
#define SHOW    Show
#define MAXINT  maxBound
sof's avatar
sof committed
254

255
#endif
256

257
258
259
\end{code}


sof's avatar
sof committed
260
*********************************************************
sof's avatar
sof committed
261
*                                                       *
sof's avatar
sof committed
262
\subsection{The interface}
sof's avatar
sof committed
263
*                                                       *
sof's avatar
sof committed
264
265
266
*********************************************************

The primitive @Doc@ values
267
268

\begin{code}
sof's avatar
sof committed
269
270
271
272
empty                     :: Doc
isEmpty                   :: Doc    -> Bool
text                      :: String -> Doc 
char                      :: Char -> Doc
sof's avatar
sof committed
273

sof's avatar
sof committed
274
semi, comma, colon, space, equals              :: Doc
sof's avatar
sof committed
275
276
277
lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc

parens, brackets, braces  :: Doc -> Doc 
sof's avatar
sof committed
278
quotes, doubleQuotes      :: Doc -> Doc
sof's avatar
sof committed
279

sof's avatar
sof committed
280
int      :: Int -> Doc
sof's avatar
sof committed
281
integer  :: Integer -> Doc
sof's avatar
sof committed
282
283
float    :: Float -> Doc
double   :: Double -> Doc
sof's avatar
sof committed
284
rational :: Rational -> Doc
285
286
\end{code}

sof's avatar
sof committed
287
Combining @Doc@ values
288
289

\begin{code}
sof's avatar
sof committed
290
291
292
293
(<>)   :: Doc -> Doc -> Doc     -- Beside
hcat   :: [Doc] -> Doc          -- List version of <>
(<+>)  :: Doc -> Doc -> Doc     -- Beside, separated by space
hsep   :: [Doc] -> Doc          -- List version of <+>
294

sof's avatar
sof committed
295
296
297
($$)   :: Doc -> Doc -> Doc     -- Above; if there is no
                                -- overlap it "dovetails" the two
vcat   :: [Doc] -> Doc          -- List version of $$
298

sof's avatar
sof committed
299
300
301
302
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
303

sof's avatar
sof committed
304
nest   :: Int -> Doc -> Doc     -- Nested
sof's avatar
sof committed
305
\end{code}
306

sof's avatar
sof committed
307
GHC-specific ones.
308

sof's avatar
sof committed
309
310
\begin{code}
hang :: Doc -> Int -> Doc -> Doc
sof's avatar
sof committed
311
punctuate :: Doc -> [Doc] -> [Doc]      -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
sof's avatar
sof committed
312
\end{code}
313

sof's avatar
sof committed
314
Displaying @Doc@ values. 
315

sof's avatar
sof committed
316
317
318
319
\begin{code}
instance SHOW Doc where
  showsPrec prec doc cont = showDoc doc cont

sof's avatar
sof committed
320
render     :: Doc -> String             -- Uses default style
sof's avatar
sof committed
321
fullRender :: Mode
sof's avatar
sof committed
322
323
324
325
326
327
328
329
           -> 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

{-      When we start using 1.3 
sof's avatar
sof committed
330
renderStyle  :: Style -> Doc -> String
sof's avatar
sof committed
331
332
333
334
335
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
336
337
338
style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
-}

sof's avatar
sof committed
339
340
341
342
data Mode = PageMode            -- Normal 
          | ZigZagMode          -- With zig-zag cuts
          | LeftMode            -- No indentation, infinitely long lines
          | OneLineMode         -- All on one line
343
344
345

\end{code}

sof's avatar
sof committed
346
347

*********************************************************
sof's avatar
sof committed
348
*                                                       *
sof's avatar
sof committed
349
\subsection{The @Doc@ calculus}
sof's avatar
sof committed
350
*                                                       *
sof's avatar
sof committed
351
352
353
354
355
356
*********************************************************

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

sof's avatar
sof committed
361
        ...ditto $+$...
sof's avatar
sof committed
362
363
364

Laws for <>
~~~~~~~~~~~
sof's avatar
sof committed
365
366
367
<b1>    (x <> y) <> z   = x <> (y <> z)
<b2>    empty <> x      = empty
<b3>    x <> empty      = x
sof's avatar
sof committed
368

sof's avatar
sof committed
369
        ...ditto <+>...
sof's avatar
sof committed
370
371
372

Laws for text
~~~~~~~~~~~~~
sof's avatar
sof committed
373
374
<t1>    text s <> text t        = text (s++t)
<t2>    text "" <> x            = x, if x non-empty
sof's avatar
sof committed
375
376
377

Laws for nest
~~~~~~~~~~~~~
sof's avatar
sof committed
378
379
380
381
382
383
<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
384
385
386
387
388
389

** Note the side condition on <n6>!  It is this that
** makes it OK for empty to be a left unit for <>.

Miscellaneous
~~~~~~~~~~~~~
sof's avatar
sof committed
390
391
<m1>    (text s <> x) $$ y = text s <> ((text "" <> x)) $$ 
                                         nest (-length s) y)
sof's avatar
sof committed
392

sof's avatar
sof committed
393
394
<m2>    (x $$ y) <> z = x $$ (y <> z)
        if y non-empty
sof's avatar
sof committed
395
396
397
398


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

sof's avatar
sof committed
402
403
<l2>    nest k (sep ps) = sep (map (nest k) ps)
        ...ditto hsep, hcat, vcat, fill...
sof's avatar
sof committed
404
405
406

Laws for oneLiner
~~~~~~~~~~~~~~~~~
sof's avatar
sof committed
407
408
<o1>    oneLiner (nest k p) = nest k (oneLiner p)
<o2>    oneLiner (x <> y)   = oneLiner x <> oneLiner y 
sof's avatar
sof committed
409
410
411
412
413
414
\end{verbatim}


You might think that the following verion of <m1> would
be neater:
\begin{verbatim}
sof's avatar
sof committed
415
416
<3 NO>  (text s <> x) $$ y = text s <> ((empty <> x)) $$ 
                                         nest (-length s) y)
sof's avatar
sof committed
417
418
419
\end{verbatim}
But it doesn't work, for if x=empty, we would have
\begin{verbatim}
sof's avatar
sof committed
420
421
        text s $$ y = text s <> (empty $$ nest (-length s) y)
                    = text s <> nest (-length s) y
sof's avatar
sof committed
422
423
424
425
426
\end{verbatim}



*********************************************************
sof's avatar
sof committed
427
*                                                       *
sof's avatar
sof committed
428
\subsection{Simple derived definitions}
sof's avatar
sof committed
429
*                                                       *
sof's avatar
sof committed
430
*********************************************************
431
432

\begin{code}
sof's avatar
sof committed
433
434
435
436
437
438
439
440
441
442
443
444
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
445
int      n = text (show n)
sof's avatar
sof committed
446
447
448
integer  n = text (show n)
float    n = text (show n)
double   n = text (show n)
sof's avatar
sof committed
449
450
rational n = text (show (fromRat n))
--rational n = text (show (fromRationalX n)) -- _showRational 30 n)
sof's avatar
sof committed
451

sof's avatar
sof committed
452
453
454
455
456
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
457

mnislaih's avatar
mnislaih committed
458
459
cparen True  = parens
cparen False = id
sof's avatar
sof committed
460
461
462
463
464

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

465
hang d1 n d2 = sep [d1, nest n d2]
sof's avatar
sof committed
466
467
468

punctuate p []     = []
punctuate p (d:ds) = go d ds
sof's avatar
sof committed
469
470
471
                   where
                     go d [] = [d]
                     go d (e:es) = (d <> p) : go e es
472
473
474
\end{code}


sof's avatar
sof committed
475
*********************************************************
sof's avatar
sof committed
476
*                                                       *
sof's avatar
sof committed
477
\subsection{The @Doc@ data type}
sof's avatar
sof committed
478
*                                                       *
sof's avatar
sof committed
479
480
481
482
*********************************************************

A @Doc@ represents a {\em set} of layouts.  A @Doc@ with
no occurrences of @Union@ or @NoDoc@ represents just one layout.
483
\begin{code}
sof's avatar
sof committed
484
data Doc
sof's avatar
sof committed
485
486
 = Empty                                -- empty
 | NilAbove Doc                         -- text "" $$ x
487
 | TextBeside !TextDetails INT Doc       -- text s <> x  
sof's avatar
sof committed
488
489
490
491
492
 | Nest INT Doc                         -- nest k x
 | 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
493

sof's avatar
sof committed
494
type RDoc = Doc         -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
sof's avatar
sof committed
495
496
497
498
499


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
500
reduceDoc p              = p
sof's avatar
sof committed
501
502


503
data TextDetails = Chr  {-#UNPACK#-}!Char
sof's avatar
sof committed
504
                 | Str  String
505
506
507
                 | PStr FastString	-- a hashed string
		 | LStr Addr# Int#	-- a '\0'-terminated array of bytes

sof's avatar
sof committed
508
509
space_text = Chr ' '
nl_text    = Chr '\n'
510
511
\end{code}

sof's avatar
sof committed
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
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@.

\item 
The layouts of the two arguments of @Union@ both flatten to the same string.

\item 
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.

\item 
An empty document is always represented by @Empty@.
It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.

\item 
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}
sof's avatar
sof committed
545
        -- Arg of a NilAbove is always an RDoc
sof's avatar
sof committed
546
nilAbove_ p = LOCAL_ASSERT( ok p ) NilAbove p
sof's avatar
sof committed
547
548
549
            where
              ok Empty = False
              ok other = True
sof's avatar
sof committed
550

sof's avatar
sof committed
551
        -- Arg of a TextBeside is always an RDoc
sof's avatar
sof committed
552
textBeside_ s sl p = TextBeside s sl (LOCAL_ASSERT( ok p ) p)
sof's avatar
sof committed
553
554
555
                   where
                     ok (Nest _ _) = False
                     ok other      = True
sof's avatar
sof committed
556

sof's avatar
sof committed
557
        -- Arg of Nest is always an RDoc
sof's avatar
sof committed
558
nest_ k p = Nest k (LOCAL_ASSERT( ok p ) p)
sof's avatar
sof committed
559
560
561
          where
            ok Empty = False
            ok other = True
sof's avatar
sof committed
562

sof's avatar
sof committed
563
        -- Args of union are always RDocs
sof's avatar
sof committed
564
union_ p q = Union (LOCAL_ASSERT( ok p ) p) (LOCAL_ASSERT( ok q ) q)
sof's avatar
sof committed
565
566
567
568
569
           where
             ok (TextBeside _ _ _) = True
             ok (NilAbove _)       = True
             ok (Union _ _)        = True
             ok other              = False
sof's avatar
sof committed
570
571
572
573
\end{code}


Notice the difference between
sof's avatar
sof committed
574
575
576
577
        * 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
578
579
580
581



*********************************************************
sof's avatar
sof committed
582
*                                                       *
sof's avatar
sof committed
583
\subsection{@empty@, @text@, @nest@, @union@}
sof's avatar
sof committed
584
*                                                       *
sof's avatar
sof committed
585
*********************************************************
586
587

\begin{code}
sof's avatar
sof committed
588
589
empty = Empty

sof's avatar
sof committed
590
591
592
isEmpty Empty = True
isEmpty _     = False

sof's avatar
sof committed
593
594
char  c = textBeside_ (Chr c) 1# Empty
text  s = case length   s of {IBOX(sl) -> textBeside_ (Str s)  sl Empty}
595
ftext s = case lengthFS s of {IBOX(sl) -> textBeside_ (PStr s) sl Empty}
596
ptext (Ptr s) = case strLength (Ptr s) of {IBOX(sl) -> textBeside_ (LStr s sl) sl Empty}
sof's avatar
sof committed
597

598
599
600
-- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
-- intermediate packing/unpacking of the string.
{-# RULES 
601
  "text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
602
603
 #-}

sof's avatar
sof committed
604
nest IBOX(k)  p = mkNest k (reduceDoc p)        -- Externally callable version
sof's avatar
sof committed
605
606
607
608
609

-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
mkNest k       (Nest k1 p) = mkNest (k PLUS k1) p
mkNest k       NoDoc       = NoDoc
mkNest k       Empty       = Empty
sof's avatar
sof committed
610
611
mkNest ILIT(0) p           = p                  -- Worth a try!
mkNest k       p           = nest_ k p
sof's avatar
sof committed
612
613
614
615

-- mkUnion checks for an empty document
mkUnion Empty q = Empty
mkUnion p q     = p `union_` q
616
617
\end{code}

sof's avatar
sof committed
618
*********************************************************
sof's avatar
sof committed
619
*                                                       *
sof's avatar
sof committed
620
\subsection{Vertical composition @$$@}
sof's avatar
sof committed
621
*                                                       *
sof's avatar
sof committed
622
623
*********************************************************

624
625

\begin{code}
sof's avatar
sof committed
626
627
628
629
630
631
p $$  q = Above p False q
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)
above p@(Beside _ _ _) g  q  = aboveNest (reduceDoc p) g ILIT(0) (reduceDoc q)
sof's avatar
sof committed
632
above p g q                  = aboveNest p             g ILIT(0) (reduceDoc q)
sof's avatar
sof committed
633
634
635
636
637
638

aboveNest :: RDoc -> Bool -> INT -> RDoc -> RDoc
-- Specfication: aboveNest p g k q = p $g$ (nest k q)

aboveNest NoDoc               g k q = NoDoc
aboveNest (p1 `Union` p2)     g k q = aboveNest p1 g k q `union_` 
sof's avatar
sof committed
639
640
                                      aboveNest p2 g k q
                                
sof's avatar
sof committed
641
642
aboveNest Empty               g k q = mkNest k q
aboveNest (Nest k1 p)         g k q = nest_ k1 (aboveNest p g (k MINUS k1) q)
sof's avatar
sof committed
643
644
                                  -- p can't be Empty, so no need for mkNest
                                
sof's avatar
sof committed
645
646
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
647
648
649
650
651
                                    where
                                      k1   = k MINUS sl
                                      rest = case p of
                                                Empty -> nilAboveNest g k1 q
                                                other -> aboveNest  p g k1 q
652
653
654
\end{code}

\begin{code}
sof's avatar
sof committed
655
656
nilAboveNest :: Bool -> INT -> RDoc -> RDoc
-- Specification: text s <> nilaboveNest g k q 
sof's avatar
sof committed
657
--              = text s <> (text "" $g$ nest k q)
sof's avatar
sof committed
658

sof's avatar
sof committed
659
nilAboveNest g k Empty       = Empty    -- Here's why the "text s <>" is in the spec!
sof's avatar
sof committed
660
661
nilAboveNest g k (Nest k1 q) = nilAboveNest g (k PLUS k1) q

sof's avatar
sof committed
662
663
664
665
nilAboveNest g k q           | (not g) && (k GR ILIT(0))        -- No newline if no overlap
                             = textBeside_ (Str (spaces k)) k q
                             | otherwise                        -- Put them really above
                             = nilAbove_ (mkNest k q)
sof's avatar
sof committed
666
667
668
669
\end{code}


*********************************************************
sof's avatar
sof committed
670
*                                                       *
sof's avatar
sof committed
671
\subsection{Horizontal composition @<>@}
sof's avatar
sof committed
672
*                                                       *
sof's avatar
sof committed
673
674
675
676
677
678
679
680
681
682
683
684
*********************************************************

\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
 
beside NoDoc               g q   = NoDoc
beside (p1 `Union` p2)     g q   = (beside p1 g q) `union_` (beside p2 g q)
beside Empty               g q   = q
685
beside (Nest k p)          g q   = nest_ k $! beside p g q       -- p non-empty
sof's avatar
sof committed
686
beside p@(Beside p1 g1 q1) g2 q2 
sof's avatar
sof committed
687
688
           {- (A `op1` B) `op2` C == A `op1` (B `op2` C)  iff op1 == op2 
                                                 [ && (op1 == <> || op1 == <+>) ] -}
689
         | g1 == g2              = beside p1 g1 $! beside q1 g2 q2
sof's avatar
sof committed
690
         | otherwise             = beside (reduceDoc p) g2 q2
691
692
693
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
694
695
696
697
                               where
                                  rest = case p of
                                           Empty -> nilBeside g q
                                           other -> beside p g q
698
699
700
\end{code}

\begin{code}
sof's avatar
sof committed
701
702
nilBeside :: Bool -> RDoc -> RDoc
-- Specification: text "" <> nilBeside g p 
sof's avatar
sof committed
703
--              = text "" <g> p
sof's avatar
sof committed
704

sof's avatar
sof committed
705
nilBeside g Empty      = Empty  -- Hence the text "" in the spec
sof's avatar
sof committed
706
nilBeside g (Nest _ p) = nilBeside g p
sof's avatar
sof committed
707
708
nilBeside g p          | g         = textBeside_ space_text ILIT(1) p
                       | otherwise = p
709
710
\end{code}

sof's avatar
sof committed
711
*********************************************************
sof's avatar
sof committed
712
*                                                       *
sof's avatar
sof committed
713
\subsection{Separate, @sep@, Hughes version}
sof's avatar
sof committed
714
*                                                       *
sof's avatar
sof committed
715
*********************************************************
716
717

\begin{code}
sof's avatar
sof committed
718
-- Specification: sep ps  = oneLiner (hsep ps)
sof's avatar
sof committed
719
720
--                         `union`
--                          vcat ps
sof's avatar
sof committed
721

sof's avatar
sof committed
722
723
sep = sepX True         -- Separate with spaces
cat = sepX False        -- Don't
sof's avatar
sof committed
724
725
726
727
728
729

sepX x []     = empty
sepX x (p:ps) = sep1 x (reduceDoc p) ILIT(0) ps


-- Specification: sep1 g k ys = sep (x : map (nest k) ys)
sof's avatar
sof committed
730
731
--                            = oneLiner (x <g> nest k (hsep ys))
--                              `union` x $$ nest k (vcat ys)
sof's avatar
sof committed
732
733

sep1 :: Bool -> RDoc -> INT -> [Doc] -> RDoc
sof's avatar
sof committed
734
sep1 g NoDoc               k ys = NoDoc
sof's avatar
sof committed
735
sep1 g (p `Union` q)       k ys = sep1 g p k ys
sof's avatar
sof committed
736
737
                                  `union_`
                                  (aboveNest q False k (reduceDoc (vcat ys)))
sof's avatar
sof committed
738
739
740
741
742
743
744
745
746
747
748
749
750
751

sep1 g Empty               k ys = mkNest k (sepX g ys)
sep1 g (Nest n p)          k ys = nest_ n (sep1 g p (k MINUS n) ys)

sep1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k MINUS sl) ys)

-- 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

sepNB g (Nest _ p)  k ys  = sepNB g p k ys

sepNB g Empty k ys        = oneLiner (nilBeside g (reduceDoc rest))
sof's avatar
sof committed
752
753
754
755
756
                                `mkUnion` 
                            nilAboveNest False k (reduceDoc (vcat ys))
                          where
                            rest | g         = hsep ys
                                 | otherwise = hcat ys
sof's avatar
sof committed
757

sof's avatar
sof committed
758
sepNB g p k ys            = sep1 g p k ys
759
760
\end{code}

sof's avatar
sof committed
761
*********************************************************
sof's avatar
sof committed
762
*                                                       *
sof's avatar
sof committed
763
\subsection{@fill@}
sof's avatar
sof committed
764
*                                                       *
sof's avatar
sof committed
765
766
*********************************************************

767
\begin{code}
sof's avatar
sof committed
768
769
770
771
772
773
774
fsep = fill True
fcat = fill False

-- Specification: 
--   fill []  = empty
--   fill [p] = p
--   fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) 
sof's avatar
sof committed
775
776
777
--                                          (fill (oneLiner p2 : ps))
--                     `union`
--                      p1 $$ fill ps
sof's avatar
sof committed
778
779
780
781
782
783

fill g []     = empty
fill g (p:ps) = fill1 g (reduceDoc p) ILIT(0) ps


fill1 :: Bool -> RDoc -> INT -> [Doc] -> Doc
sof's avatar
sof committed
784
fill1 g NoDoc               k ys = NoDoc
sof's avatar
sof committed
785
fill1 g (p `Union` q)       k ys = fill1 g p k ys
sof's avatar
sof committed
786
787
                                   `union_`
                                   (aboveNest q False k (fill g ys))
sof's avatar
sof committed
788
789
790
791
792
793
794
795
796
797

fill1 g Empty               k ys = mkNest k (fill g ys)
fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k MINUS n) ys)

fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fill g ys))
fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k MINUS sl) ys)

fillNB g (Nest _ p)  k ys  = fillNB g p k ys
fillNB g Empty k []        = Empty
fillNB g Empty k (y:ys)    = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
sof's avatar
sof committed
798
799
800
801
802
                             `mkUnion` 
                             nilAboveNest False k (fill g (y:ys))
                           where
                             k1 | g         = k MINUS ILIT(1)
                                | otherwise = k
sof's avatar
sof committed
803

sof's avatar
sof committed
804
fillNB g p k ys            = fill1 g p k ys
805
806
\end{code}

807

sof's avatar
sof committed
808
*********************************************************
sof's avatar
sof committed
809
*                                                       *
sof's avatar
sof committed
810
\subsection{Selecting the best layout}
sof's avatar
sof committed
811
*                                                       *
sof's avatar
sof committed
812
*********************************************************
813
814

\begin{code}
815
best :: Int             -- Line length
sof's avatar
sof committed
816
     -> Int             -- Ribbon length
sof's avatar
sof committed
817
     -> RDoc
sof's avatar
sof committed
818
     -> RDoc            -- No unions in here!
sof's avatar
sof committed
819

820
best IBOX(w) IBOX(r) p
sof's avatar
sof committed
821
822
  = get w p
  where
sof's avatar
sof committed
823
    get :: INT          -- (Remaining) width of line
sof's avatar
sof committed
824
825
826
827
828
829
830
831
        -> Doc -> Doc
    get w Empty               = Empty
    get w NoDoc               = NoDoc
    get w (NilAbove p)        = nilAbove_ (get w p)
    get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
    get w (Nest k p)          = nest_ k (get (w MINUS k) p)
    get w (p `Union` q)       = nicest w r (get w p) (get w q)

sof's avatar
sof committed
832
833
834
835
    get1 :: INT         -- (Remaining) width of line
         -> INT         -- Amount of first line already eaten up
         -> Doc         -- This is an argument to TextBeside => eat Nests
         -> Doc         -- No unions in here!
sof's avatar
sof committed
836
837
838
839
840
841
842

    get1 w sl Empty               = Empty
    get1 w sl NoDoc               = NoDoc
    get1 w sl (NilAbove p)        = nilAbove_ (get (w MINUS sl) p)
    get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl PLUS tl) p)
    get1 w sl (Nest k p)          = get1 w sl p
    get1 w sl (p `Union` q)       = nicest1 w r sl (get1 w sl p) 
sof's avatar
sof committed
843
                                                   (get1 w sl q)
sof's avatar
sof committed
844
845
846

nicest w r p q = nicest1 w r ILIT(0) p q
nicest1 w r sl p q | fits ((w `minn` r) MINUS sl) p = p
sof's avatar
sof committed
847
                   | otherwise                   = q
sof's avatar
sof committed
848

sof's avatar
sof committed
849
fits :: INT     -- Space available
sof's avatar
sof committed
850
     -> Doc
sof's avatar
sof committed
851
     -> Bool    -- True if *first line* of Doc fits in space available
sof's avatar
sof committed
852
853
854
855
856
857
858
859
 
fits n p    | n LT ILIT(0) = False
fits n NoDoc               = False
fits n Empty               = True
fits n (NilAbove _)        = True
fits n (TextBeside _ sl p) = fits (n MINUS sl) p

minn x y | x LT y    = x
sof's avatar
sof committed
860
         | otherwise = y
sof's avatar
sof committed
861
862
863
864
\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.
865

sof's avatar
sof committed
866
867
\begin{code}
first p q | nonEmptySet p = p 
sof's avatar
sof committed
868
          | otherwise     = q
sof's avatar
sof committed
869

870
nonEmptySet NoDoc              = False
sof's avatar
sof committed
871
nonEmptySet (p `Union` q)      = True
sof's avatar
sof committed
872
873
nonEmptySet Empty              = True
nonEmptySet (NilAbove p)       = True           -- NoDoc always in first line
sof's avatar
sof committed
874
875
876
877
878
879
880
881
882
883
884
885
886
887
nonEmptySet (TextBeside _ _ p) = nonEmptySet p
nonEmptySet (Nest _ p)         = nonEmptySet p
\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
oneLiner (NilAbove p)        = NoDoc
oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
oneLiner (Nest k p)          = nest_ k (oneLiner p)
oneLiner (p `Union` q)       = oneLiner p
888
889
890
\end{code}


sof's avatar
sof committed
891
892

*********************************************************
sof's avatar
sof committed
893
*                                                       *
sof's avatar
sof committed
894
\subsection{Displaying the best layout}
sof's avatar
sof committed
895
*                                                       *
sof's avatar
sof committed
896
897
*********************************************************

898
899

\begin{code}
sof's avatar
sof committed
900
901
902
903
{-
renderStyle Style{mode, lineLength, ribbonsPerLine} doc 
  = fullRender mode lineLength ribbonsPerLine doc ""
-}
904

905
906
907
908
909
910
911
912
render doc       = showDocWith PageMode doc
showDoc doc rest = showDocWithAppend PageMode doc rest

showDocWithAppend :: Mode -> Doc -> String -> String
showDocWithAppend mode doc rest = fullRender mode 100 1.5 string_txt rest doc

showDocWith :: Mode -> Doc -> String
showDocWith mode doc = showDocWithAppend mode doc ""
913

sof's avatar
sof committed
914
915
string_txt (Chr c)   s  = c:s
string_txt (Str s1)  s2 = s1 ++ s2
916
917
918
919
920
921
922
923
924
925
926
string_txt (PStr s1) s2 = unpackFS s1 ++ s2
string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2

unpackLitString addr =
 unpack 0#
 where
    unpack nh
      | ch `eqChar#` '\0'# = []
      | otherwise   = C# ch : unpack (nh +# 1#)
      where
	ch = indexCharOffAddr# addr nh
sof's avatar
sof committed
927
\end{code}
928

sof's avatar
sof committed
929
930
\begin{code}

931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
fullRender OneLineMode _ _ txt end doc 
  = lay (reduceDoc doc)
  where
    lay NoDoc               = cant_fail
    lay (Union p q)         = (lay q)			-- Second arg can't be NoDoc
    lay (Nest k p)          = lay p
    lay Empty               = end
    lay (NilAbove p)        = space_text `txt` lay p	-- NoDoc always on first line
    lay (TextBeside s sl p) = s `txt` lay p

fullRender LeftMode    _ _ txt end doc 
  = lay (reduceDoc doc)
  where
    lay NoDoc               	= cant_fail
    lay (Union p q) 		= lay (first p q)
    lay (Nest k p)          	= lay p
    lay Empty               	= end
    lay (NilAbove p)        	= nl_text `txt` lay p	-- NoDoc always on first line
    lay (TextBeside s sl p) 	= s `txt` lay p
sof's avatar
sof committed
950
951
952
953

fullRender mode line_length ribbons_per_line txt end doc
  = display mode line_length ribbon_length txt end best_doc
  where 
954
    best_doc = best hacked_line_length ribbon_length (reduceDoc doc)
sof's avatar
sof committed
955
956

    hacked_line_length, ribbon_length :: Int
957
    ribbon_length = round (fromIntegral line_length / ribbons_per_line)
sof's avatar
sof committed
958
959
960
961
962
963
    hacked_line_length = case mode of { ZigZagMode -> MAXINT; other -> line_length }

display mode IBOX(page_width) IBOX(ribbon_width) txt end doc
  = case page_width MINUS ribbon_width of { gap_width ->
    case gap_width DIV ILIT(2) of { shift ->
    let
sof's avatar
sof committed
964
965
        lay k (Nest k1 p)  = lay (k PLUS k1) p
        lay k Empty        = end
sof's avatar
sof committed
966
    
sof's avatar
sof committed
967
        lay k (NilAbove p) = nl_text `txt` lay k p
sof's avatar
sof committed
968
    
sof's avatar
sof committed
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
        lay k (TextBeside s sl p)
            = case mode of
                    ZigZagMode |  k GREQ gap_width
                               -> nl_text `txt` (
                                  Str (multi_ch shift '/') `txt` (
                                  nl_text `txt` (
                                  lay1 (k MINUS shift) s sl p)))

                               |  k LT ILIT(0)
                               -> nl_text `txt` (
                                  Str (multi_ch shift '\\') `txt` (
                                  nl_text `txt` (
                                  lay1 (k PLUS shift) s sl p )))

                    other -> lay1 k s sl p
sof's avatar
sof committed
984
    
sof's avatar
sof committed
985
        lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k PLUS sl) p)
sof's avatar
sof committed
986
    
sof's avatar
sof committed
987
988
989
990
        lay2 k (NilAbove p)        = nl_text `txt` lay k p
        lay2 k (TextBeside s sl p) = s `txt` (lay2 (k PLUS sl) p)
        lay2 k (Nest _ p)          = lay2 k p
        lay2 k Empty               = end
sof's avatar
sof committed
991
992
993
994
995
996
997
    in
    lay ILIT(0) doc
    }}

cant_fail = error "easy_display: NoDoc"

indent n | n GREQ ILIT(8) = '\t' : indent (n MINUS ILIT(8))
sof's avatar
sof committed
998
         | otherwise      = spaces n
sof's avatar
sof committed
999

1000
1001
multi_ch n ch | n LTEQ ILIT(0) = ""
	      | otherwise      = ch : multi_ch (n MINUS ILIT(1)) ch
sof's avatar
sof committed
1002

1003
1004
spaces n | n LTEQ ILIT(0) = ""
         | otherwise      = ' ' : spaces (n MINUS ILIT(1))
1005
\end{code}
1006
1007

\begin{code}
1008
pprCols = (120 :: Int) -- could make configurable
1009
1010

printDoc :: Mode -> Handle -> Doc -> IO ()
1011
1012
printDoc LeftMode hdl doc
  = do { printLeftRender hdl doc; hFlush hdl }
1013
printDoc mode hdl doc
1014
1015
  = do { fullRender mode pprCols 1.5 put done doc ;
	 hFlush hdl }
1016
1017
1018
1019
  where
    put (Chr c)  next = hPutChar hdl c >> next 
    put (Str s)  next = hPutStr  hdl s >> next 
    put (PStr s) next = hPutFS   hdl s >> next 
1020
    put (LStr s l) next = hPutLitString hdl s l >> next 
1021
1022

    done = hPutChar hdl '\n'
1023

1024
1025
  -- some versions of hPutBuf will barf if the length is zero
hPutLitString handle a# 0# = return ()
1026
1027
hPutLitString handle a# l#
  = hPutBuf handle (Ptr a#) (I# l#)
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066

-- Printing output in LeftMode is performance critical: it's used when
-- dumping C and assembly output, so we allow ourselves a few dirty
-- hacks:
--
--	(1) we specialise fullRender for LeftMode with IO output.
--
--	(2) we add a layer of buffering on top of Handles.  Handles
--	    don't perform well with lots of hPutChars, which is mostly
--	    what we're doing here, because Handles have to be thread-safe
--	    and async exception-safe.  We only have a single thread and don't
--	    care about exceptions, so we add a layer of fast buffering
--	    over the Handle interface.
--
--	(3) a few hacks in layLeft below to convince GHC to generate the right
--	    code.

printLeftRender :: Handle -> Doc -> IO ()
printLeftRender hdl doc = do
  b <- newBufHandle hdl
  layLeft b (reduceDoc doc)
  bFlush b

-- HACK ALERT!  the "return () >>" below convinces GHC to eta-expand
-- this function with the IO state lambda.  Otherwise we end up with
-- closures in all the case branches.
layLeft b _ | b `seq` False = undefined	-- make it strict in b
layLeft b NoDoc               	= cant_fail
layLeft b (Union p q) 		= return () >> layLeft b (first p q)
layLeft b (Nest k p)          	= return () >> layLeft b p
layLeft b Empty               	= bPutChar b '\n'
layLeft b (NilAbove p)        	= bPutChar b '\n' >> layLeft b p
layLeft b (TextBeside s sl p) 	= put b s >> layLeft b p
 where
    put b _ | b `seq` False = undefined
    put b (Chr c)    = bPutChar b c
    put b (Str s)    = bPutStr  b s
    put b (PStr s)   = bPutFS   b s
    put b (LStr s l) = bPutLitString b s l
1067
\end{code}