Pretty.lhs 36.8 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
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
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

Ian Lynagh's avatar
Ian Lynagh committed
167
168
169
170
        (<>), (<+>), hcat, hsep,
        ($$), ($+$), vcat,
        sep, cat,
        fsep, fcat,
sof's avatar
sof committed
171
172

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

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

178
import BufWrite
sof's avatar
sof committed
179
import FastString
180
import FastTypes
Ian Lynagh's avatar
Ian Lynagh committed
181
import Panic
182
183

import Numeric (fromRat)
Simon Marlow's avatar
Simon Marlow committed
184
import System.IO
185
--import Foreign.Ptr (castPtr)
186

187
188
#if defined(__GLASGOW_HASKELL__)
--for a RULES
Ian Lynagh's avatar
Ian Lynagh committed
189
import GHC.Base ( unpackCString# )
Ian Lynagh's avatar
Ian Lynagh committed
190
import GHC.Exts ( Int# )
Ian Lynagh's avatar
Ian Lynagh committed
191
import GHC.Ptr  ( Ptr(..) )
192
#endif
193

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

Ian Lynagh's avatar
Ian Lynagh committed
196
infixl 6 <>
sof's avatar
sof committed
197
198
199
infixl 6 <+>
infixl 5 $$, $+$
\end{code}
200
201


sof's avatar
sof committed
202
203
204
205
206
\begin{code}

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

207
208
209
\end{code}


sof's avatar
sof committed
210
*********************************************************
sof's avatar
sof committed
211
*                                                       *
sof's avatar
sof committed
212
\subsection{The interface}
sof's avatar
sof committed
213
*                                                       *
sof's avatar
sof committed
214
215
216
*********************************************************

The primitive @Doc@ values
217
218

\begin{code}
sof's avatar
sof committed
219
220
empty                     :: Doc
isEmpty                   :: Doc    -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
221
text                      :: String -> Doc
sof's avatar
sof committed
222
char                      :: Char -> Doc
sof's avatar
sof committed
223

sof's avatar
sof committed
224
semi, comma, colon, space, equals              :: Doc
sof's avatar
sof committed
225
226
lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc

Ian Lynagh's avatar
Ian Lynagh committed
227
parens, brackets, braces  :: Doc -> Doc
sof's avatar
sof committed
228
quotes, doubleQuotes      :: Doc -> Doc
sof's avatar
sof committed
229

sof's avatar
sof committed
230
int      :: Int -> Doc
sof's avatar
sof committed
231
integer  :: Integer -> Doc
sof's avatar
sof committed
232
233
float    :: Float -> Doc
double   :: Double -> Doc
sof's avatar
sof committed
234
rational :: Rational -> Doc
235
236
\end{code}

sof's avatar
sof committed
237
Combining @Doc@ values
238
239

\begin{code}
sof's avatar
sof committed
240
241
242
243
(<>)   :: Doc -> Doc -> Doc     -- Beside
hcat   :: [Doc] -> Doc          -- List version of <>
(<+>)  :: Doc -> Doc -> Doc     -- Beside, separated by space
hsep   :: [Doc] -> Doc          -- List version of <+>
244

sof's avatar
sof committed
245
246
247
($$)   :: Doc -> Doc -> Doc     -- Above; if there is no
                                -- overlap it "dovetails" the two
vcat   :: [Doc] -> Doc          -- List version of $$
248

sof's avatar
sof committed
249
250
251
252
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
253

sof's avatar
sof committed
254
nest   :: Int -> Doc -> Doc     -- Nested
sof's avatar
sof committed
255
\end{code}
256

sof's avatar
sof committed
257
GHC-specific ones.
258

sof's avatar
sof committed
259
260
\begin{code}
hang :: Doc -> Int -> Doc -> Doc
sof's avatar
sof committed
261
punctuate :: Doc -> [Doc] -> [Doc]      -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
sof's avatar
sof committed
262
\end{code}
263

Ian Lynagh's avatar
Ian Lynagh committed
264
Displaying @Doc@ values.
265

sof's avatar
sof committed
266
\begin{code}
267
instance Show Doc where
Ian Lynagh's avatar
Ian Lynagh committed
268
  showsPrec _ doc cont = showDoc doc cont
sof's avatar
sof committed
269

sof's avatar
sof committed
270
render     :: Doc -> String             -- Uses default style
sof's avatar
sof committed
271
fullRender :: Mode
sof's avatar
sof committed
272
273
274
275
276
277
278
           -> 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
279
{-      When we start using 1.3
sof's avatar
sof committed
280
renderStyle  :: Style -> Doc -> String
sof's avatar
sof committed
281
282
283
284
285
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
286
287
288
style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
-}

Ian Lynagh's avatar
Ian Lynagh committed
289
data Mode = PageMode            -- Normal
sof's avatar
sof committed
290
291
292
          | ZigZagMode          -- With zig-zag cuts
          | LeftMode            -- No indentation, infinitely long lines
          | OneLineMode         -- All on one line
293
294
295

\end{code}

sof's avatar
sof committed
296
297

*********************************************************
sof's avatar
sof committed
298
*                                                       *
sof's avatar
sof committed
299
\subsection{The @Doc@ calculus}
sof's avatar
sof committed
300
*                                                       *
sof's avatar
sof committed
301
302
303
304
305
306
*********************************************************

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

sof's avatar
sof committed
311
        ...ditto $+$...
sof's avatar
sof committed
312
313
314

Laws for <>
~~~~~~~~~~~
sof's avatar
sof committed
315
316
317
<b1>    (x <> y) <> z   = x <> (y <> z)
<b2>    empty <> x      = empty
<b3>    x <> empty      = x
sof's avatar
sof committed
318

sof's avatar
sof committed
319
        ...ditto <+>...
sof's avatar
sof committed
320
321
322

Laws for text
~~~~~~~~~~~~~
sof's avatar
sof committed
323
324
<t1>    text s <> text t        = text (s++t)
<t2>    text "" <> x            = x, if x non-empty
sof's avatar
sof committed
325
326
327

Laws for nest
~~~~~~~~~~~~~
sof's avatar
sof committed
328
329
330
331
332
333
<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
334
335
336
337
338
339

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

Miscellaneous
~~~~~~~~~~~~~
Ian Lynagh's avatar
Ian Lynagh committed
340
<m1>    (text s <> x) $$ y = text s <> ((text "" <> x)) $$
sof's avatar
sof committed
341
                                         nest (-length s) y)
sof's avatar
sof committed
342

sof's avatar
sof committed
343
344
<m2>    (x $$ y) <> z = x $$ (y <> z)
        if y non-empty
sof's avatar
sof committed
345
346
347
348


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

sof's avatar
sof committed
352
353
<l2>    nest k (sep ps) = sep (map (nest k) ps)
        ...ditto hsep, hcat, vcat, fill...
sof's avatar
sof committed
354
355
356

Laws for oneLiner
~~~~~~~~~~~~~~~~~
sof's avatar
sof committed
357
<o1>    oneLiner (nest k p) = nest k (oneLiner p)
Ian Lynagh's avatar
Ian Lynagh committed
358
<o2>    oneLiner (x <> y)   = oneLiner x <> oneLiner y
sof's avatar
sof committed
359
360
361
362
363
364
\end{verbatim}


You might think that the following verion of <m1> would
be neater:
\begin{verbatim}
Ian Lynagh's avatar
Ian Lynagh committed
365
<3 NO>  (text s <> x) $$ y = text s <> ((empty <> x)) $$
sof's avatar
sof committed
366
                                         nest (-length s) y)
sof's avatar
sof committed
367
368
369
\end{verbatim}
But it doesn't work, for if x=empty, we would have
\begin{verbatim}
sof's avatar
sof committed
370
371
        text s $$ y = text s <> (empty $$ nest (-length s) y)
                    = text s <> nest (-length s) y
sof's avatar
sof committed
372
373
374
375
376
\end{verbatim}



*********************************************************
sof's avatar
sof committed
377
*                                                       *
sof's avatar
sof committed
378
\subsection{Simple derived definitions}
sof's avatar
sof committed
379
*                                                       *
sof's avatar
sof committed
380
*********************************************************
381
382

\begin{code}
sof's avatar
sof committed
383
384
385
386
387
388
389
390
391
392
393
394
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
395
int      n = text (show n)
sof's avatar
sof committed
396
397
398
integer  n = text (show n)
float    n = text (show n)
double   n = text (show n)
399
rational n = text (show (fromRat n :: Double))
sof's avatar
sof committed
400
--rational n = text (show (fromRationalX n)) -- _showRational 30 n)
sof's avatar
sof committed
401

sof's avatar
sof committed
402
403
404
405
406
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
407

Ian Lynagh's avatar
Ian Lynagh committed
408
cparen :: Bool -> Doc -> Doc
mnislaih's avatar
mnislaih committed
409
410
cparen True  = parens
cparen False = id
sof's avatar
sof committed
411
412
413
414
415

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

416
hang d1 n d2 = sep [d1, nest n d2]
sof's avatar
sof committed
417

Ian Lynagh's avatar
Ian Lynagh committed
418
punctuate _ []     = []
sof's avatar
sof committed
419
punctuate p (d:ds) = go d ds
sof's avatar
sof committed
420
421
422
                   where
                     go d [] = [d]
                     go d (e:es) = (d <> p) : go e es
423
424
425
\end{code}


sof's avatar
sof committed
426
*********************************************************
sof's avatar
sof committed
427
*                                                       *
sof's avatar
sof committed
428
\subsection{The @Doc@ data type}
sof's avatar
sof committed
429
*                                                       *
sof's avatar
sof committed
430
431
432
433
*********************************************************

A @Doc@ represents a {\em set} of layouts.  A @Doc@ with
no occurrences of @Union@ or @NoDoc@ represents just one layout.
434
\begin{code}
sof's avatar
sof committed
435
data Doc
sof's avatar
sof committed
436
437
 = Empty                                -- empty
 | NilAbove Doc                         -- text "" $$ x
Ian Lynagh's avatar
Ian Lynagh committed
438
 | TextBeside !TextDetails FastInt Doc       -- text s <> x
439
 | Nest FastInt Doc                         -- nest k x
sof's avatar
sof committed
440
441
442
443
 | 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
444

sof's avatar
sof committed
445
type RDoc = Doc         -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
sof's avatar
sof committed
446
447
448
449
450


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
451
reduceDoc p              = p
sof's avatar
sof committed
452
453


454
data TextDetails = Chr  {-#UNPACK#-}!Char
sof's avatar
sof committed
455
                 | Str  String
Ian Lynagh's avatar
Ian Lynagh committed
456
457
458
                 | PStr FastString                      -- a hashed string
                 | LStr {-#UNPACK#-}!LitString FastInt  -- a '\0'-terminated
                                                        -- array of bytes
459

Ian Lynagh's avatar
Ian Lynagh committed
460
space_text :: TextDetails
sof's avatar
sof committed
461
space_text = Chr ' '
Ian Lynagh's avatar
Ian Lynagh committed
462
nl_text :: TextDetails
sof's avatar
sof committed
463
nl_text    = Chr '\n'
464
465
\end{code}

sof's avatar
sof committed
466
467
468
469
470
471
472
473
474
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
475
\item
sof's avatar
sof committed
476
477
The layouts of the two arguments of @Union@ both flatten to the same string.

Ian Lynagh's avatar
Ian Lynagh committed
478
\item
sof's avatar
sof committed
479
480
481
482
483
484
485
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
486
\item
sof's avatar
sof committed
487
488
489
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
490
\item
sof's avatar
sof committed
491
492
493
494
495
496
497
498
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
499
500
501
-- Arg of a NilAbove is always an RDoc
nilAbove_ :: Doc -> Doc
nilAbove_ p = LOCAL_ASSERT( _ok p ) NilAbove p
sof's avatar
sof committed
502
            where
Ian Lynagh's avatar
Ian Lynagh committed
503
504
              _ok Empty = False
              _ok _     = True
sof's avatar
sof committed
505

Ian Lynagh's avatar
Ian Lynagh committed
506
507
508
-- 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
509
                   where
Ian Lynagh's avatar
Ian Lynagh committed
510
511
                     _ok (Nest _ _) = False
                     _ok _          = True
sof's avatar
sof committed
512

Ian Lynagh's avatar
Ian Lynagh committed
513
514
515
-- 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
516
          where
Ian Lynagh's avatar
Ian Lynagh committed
517
518
            _ok Empty = False
            _ok _     = True
sof's avatar
sof committed
519

Ian Lynagh's avatar
Ian Lynagh committed
520
521
522
-- 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
523
           where
Ian Lynagh's avatar
Ian Lynagh committed
524
525
526
527
             _ok (TextBeside _ _ _) = True
             _ok (NilAbove _)       = True
             _ok (Union _ _)        = True
             _ok _                  = False
sof's avatar
sof committed
528
529
530
531
\end{code}


Notice the difference between
sof's avatar
sof committed
532
533
534
535
        * 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
536
537
538
539



*********************************************************
sof's avatar
sof committed
540
*                                                       *
sof's avatar
sof committed
541
\subsection{@empty@, @text@, @nest@, @union@}
sof's avatar
sof committed
542
*                                                       *
sof's avatar
sof committed
543
*********************************************************
544
545

\begin{code}
sof's avatar
sof committed
546
547
empty = Empty

sof's avatar
sof committed
548
549
550
isEmpty Empty = True
isEmpty _     = False

551
552
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
553
ftext :: FastString -> Doc
554
ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty}
Ian Lynagh's avatar
Ian Lynagh committed
555
ptext :: LitString -> Doc
556
557
ptext s_= case iUnbox (strLength s) of {sl -> textBeside_ (LStr s sl) sl Empty}
  where s = {-castPtr-} s_
sof's avatar
sof committed
558

559
#if defined(__GLASGOW_HASKELL__)
560
561
-- 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
562
{-# RULES
563
  "text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
564
 #-}
565
#endif
566

567
nest k  p = mkNest (iUnbox k) (reduceDoc p)        -- Externally callable version
sof's avatar
sof committed
568
569

-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
Ian Lynagh's avatar
Ian Lynagh committed
570
mkNest :: Int# -> Doc -> Doc
571
mkNest k       (Nest k1 p) = mkNest (k +# k1) p
Ian Lynagh's avatar
Ian Lynagh committed
572
573
mkNest _       NoDoc       = NoDoc
mkNest _       Empty       = Empty
574
mkNest k       p  | k ==# _ILIT(0)  = p       -- Worth a try!
sof's avatar
sof committed
575
mkNest k       p           = nest_ k p
sof's avatar
sof committed
576
577

-- mkUnion checks for an empty document
Ian Lynagh's avatar
Ian Lynagh committed
578
579
mkUnion :: Doc -> Doc -> Doc
mkUnion Empty _ = Empty
sof's avatar
sof committed
580
mkUnion p q     = p `union_` q
581
582
\end{code}

sof's avatar
sof committed
583
*********************************************************
sof's avatar
sof committed
584
*                                                       *
sof's avatar
sof committed
585
\subsection{Vertical composition @$$@}
sof's avatar
sof committed
586
*                                                       *
sof's avatar
sof committed
587
588
*********************************************************

589
590

\begin{code}
sof's avatar
sof committed
591
p $$  q = Above p False q
Ian Lynagh's avatar
Ian Lynagh committed
592
($+$) :: Doc -> Doc -> Doc
sof's avatar
sof committed
593
594
595
596
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)
597
598
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
599

600
aboveNest :: RDoc -> Bool -> FastInt -> RDoc -> RDoc
sof's avatar
sof committed
601
602
-- Specfication: aboveNest p g k q = p $g$ (nest k q)

Ian Lynagh's avatar
Ian Lynagh committed
603
aboveNest NoDoc               _ _ _ = NoDoc
Ian Lynagh's avatar
Ian Lynagh committed
604
aboveNest (p1 `Union` p2)     g k q = aboveNest p1 g k q `union_`
sof's avatar
sof committed
605
                                      aboveNest p2 g k q
Ian Lynagh's avatar
Ian Lynagh committed
606

Ian Lynagh's avatar
Ian Lynagh committed
607
aboveNest Empty               _ k q = mkNest k q
608
aboveNest (Nest k1 p)         g k q = nest_ k1 (aboveNest p g (k -# k1) q)
sof's avatar
sof committed
609
                                  -- p can't be Empty, so no need for mkNest
Ian Lynagh's avatar
Ian Lynagh committed
610

sof's avatar
sof committed
611
612
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
613
                                    where
614
                                      k1   = k -# sl
sof's avatar
sof committed
615
616
                                      rest = case p of
                                                Empty -> nilAboveNest g k1 q
Ian Lynagh's avatar
Ian Lynagh committed
617
618
                                                _     -> aboveNest  p g k1 q
aboveNest _                   _ _ _ = panic "aboveNest: Unhandled case"
619
620
621
\end{code}

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

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

629
nilAboveNest g k q           | (not g) && (k ># _ILIT(0))        -- No newline if no overlap
sof's avatar
sof committed
630
631
632
                             = textBeside_ (Str (spaces k)) k q
                             | otherwise                        -- Put them really above
                             = nilAbove_ (mkNest k q)
sof's avatar
sof committed
633
634
635
636
\end{code}


*********************************************************
sof's avatar
sof committed
637
*                                                       *
sof's avatar
sof committed
638
\subsection{Horizontal composition @<>@}
sof's avatar
sof committed
639
*                                                       *
sof's avatar
sof committed
640
641
642
643
644
645
646
647
*********************************************************

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

Ian Lynagh's avatar
Ian Lynagh committed
649
beside NoDoc               _ _   = NoDoc
sof's avatar
sof committed
650
beside (p1 `Union` p2)     g q   = (beside p1 g q) `union_` (beside p2 g q)
Ian Lynagh's avatar
Ian Lynagh committed
651
beside Empty               _ q   = q
652
beside (Nest k p)          g q   = nest_ k $! beside p g q       -- p non-empty
Ian Lynagh's avatar
Ian Lynagh committed
653
654
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
655
                                                 [ && (op1 == <> || op1 == <+>) ] -}
656
         | g1 == g2              = beside p1 g1 $! beside q1 g2 q2
sof's avatar
sof committed
657
         | otherwise             = beside (reduceDoc p) g2 q2
658
659
660
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
661
662
663
                               where
                                  rest = case p of
                                           Empty -> nilBeside g q
Ian Lynagh's avatar
Ian Lynagh committed
664
                                           _     -> beside p g q
665
666
667
\end{code}

\begin{code}
sof's avatar
sof committed
668
nilBeside :: Bool -> RDoc -> RDoc
Ian Lynagh's avatar
Ian Lynagh committed
669
-- Specification: text "" <> nilBeside g p
sof's avatar
sof committed
670
--              = text "" <g> p
sof's avatar
sof committed
671

Ian Lynagh's avatar
Ian Lynagh committed
672
nilBeside _ Empty      = Empty  -- Hence the text "" in the spec
sof's avatar
sof committed
673
nilBeside g (Nest _ p) = nilBeside g p
674
nilBeside g p          | g         = textBeside_ space_text (_ILIT(1)) p
sof's avatar
sof committed
675
                       | otherwise = p
676
677
\end{code}

sof's avatar
sof committed
678
*********************************************************
sof's avatar
sof committed
679
*                                                       *
sof's avatar
sof committed
680
\subsection{Separate, @sep@, Hughes version}
sof's avatar
sof committed
681
*                                                       *
sof's avatar
sof committed
682
*********************************************************
683
684

\begin{code}
sof's avatar
sof committed
685
-- Specification: sep ps  = oneLiner (hsep ps)
sof's avatar
sof committed
686
687
--                         `union`
--                          vcat ps
sof's avatar
sof committed
688

sof's avatar
sof committed
689
690
sep = sepX True         -- Separate with spaces
cat = sepX False        -- Don't
sof's avatar
sof committed
691

Ian Lynagh's avatar
Ian Lynagh committed
692
693
sepX :: Bool -> [Doc] -> Doc
sepX _ []     = empty
694
sepX x (p:ps) = sep1 x (reduceDoc p) (_ILIT(0)) ps
sof's avatar
sof committed
695
696
697


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

701
sep1 :: Bool -> RDoc -> FastInt -> [Doc] -> RDoc
Ian Lynagh's avatar
Ian Lynagh committed
702
sep1 _ NoDoc               _ _  = NoDoc
sof's avatar
sof committed
703
sep1 g (p `Union` q)       k ys = sep1 g p k ys
sof's avatar
sof committed
704
705
                                  `union_`
                                  (aboveNest q False k (reduceDoc (vcat ys)))
sof's avatar
sof committed
706
707

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

Ian Lynagh's avatar
Ian Lynagh committed
710
sep1 _ (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
711
sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k -# sl) ys)
Ian Lynagh's avatar
Ian Lynagh committed
712
sep1 _ _                   _ _  = panic "sep1: Unhandled case"
sof's avatar
sof committed
713
714
715
716
717

-- 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
718
sepNB :: Bool -> Doc -> FastInt -> [Doc] -> Doc
sof's avatar
sof committed
719
720
721
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
722
                                `mkUnion`
sof's avatar
sof committed
723
724
725
726
                            nilAboveNest False k (reduceDoc (vcat ys))
                          where
                            rest | g         = hsep ys
                                 | otherwise = hcat ys
sof's avatar
sof committed
727

sof's avatar
sof committed
728
sepNB g p k ys            = sep1 g p k ys
729
730
\end{code}

sof's avatar
sof committed
731
*********************************************************
sof's avatar
sof committed
732
*                                                       *
sof's avatar
sof committed
733
\subsection{@fill@}
sof's avatar
sof committed
734
*                                                       *
sof's avatar
sof committed
735
736
*********************************************************

737
\begin{code}
sof's avatar
sof committed
738
739
740
fsep = fill True
fcat = fill False

Ian Lynagh's avatar
Ian Lynagh committed
741
-- Specification:
sof's avatar
sof committed
742
743
--   fill []  = empty
--   fill [p] = p
Ian Lynagh's avatar
Ian Lynagh committed
744
--   fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
sof's avatar
sof committed
745
746
747
--                                          (fill (oneLiner p2 : ps))
--                     `union`
--                      p1 $$ fill ps
sof's avatar
sof committed
748

Ian Lynagh's avatar
Ian Lynagh committed
749
750
fill :: Bool -> [Doc] -> Doc
fill _ []     = empty
751
fill g (p:ps) = fill1 g (reduceDoc p) (_ILIT(0)) ps
sof's avatar
sof committed
752
753


754
fill1 :: Bool -> RDoc -> FastInt -> [Doc] -> Doc
Ian Lynagh's avatar
Ian Lynagh committed
755
fill1 _ NoDoc               _ _  = NoDoc
sof's avatar
sof committed
756
fill1 g (p `Union` q)       k ys = fill1 g p k ys
sof's avatar
sof committed
757
758
                                   `union_`
                                   (aboveNest q False k (fill g ys))
sof's avatar
sof committed
759
760

fill1 g Empty               k ys = mkNest k (fill g ys)
761
fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k -# n) ys)
sof's avatar
sof committed
762
763

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

Ian Lynagh's avatar
Ian Lynagh committed
767
fillNB :: Bool -> Doc -> Int# -> [Doc] -> Doc
sof's avatar
sof committed
768
fillNB g (Nest _ p)  k ys  = fillNB g p k ys
Ian Lynagh's avatar
Ian Lynagh committed
769
fillNB _ Empty _ []        = Empty
sof's avatar
sof committed
770
fillNB g Empty k (y:ys)    = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
Ian Lynagh's avatar
Ian Lynagh committed
771
                             `mkUnion`
sof's avatar
sof committed
772
773
                             nilAboveNest False k (fill g (y:ys))
                           where
774
                             k1 | g         = k -# _ILIT(1)
sof's avatar
sof committed
775
                                | otherwise = k
sof's avatar
sof committed
776

sof's avatar
sof committed
777
fillNB g p k ys            = fill1 g p k ys
778
779
\end{code}

780

sof's avatar
sof committed
781
*********************************************************
sof's avatar
sof committed
782
*                                                       *
sof's avatar
sof committed
783
\subsection{Selecting the best layout}
sof's avatar
sof committed
784
*                                                       *
sof's avatar
sof committed
785
*********************************************************
786
787

\begin{code}
788
best :: Int             -- Line length
sof's avatar
sof committed
789
     -> Int             -- Ribbon length
sof's avatar
sof committed
790
     -> RDoc
sof's avatar
sof committed
791
     -> RDoc            -- No unions in here!
sof's avatar
sof committed
792

793
794
best w_ r_ p
  = get (iUnbox w_) p
sof's avatar
sof committed
795
  where
796
797
    r = iUnbox r_
    get :: FastInt          -- (Remaining) width of line
sof's avatar
sof committed
798
        -> Doc -> Doc
Ian Lynagh's avatar
Ian Lynagh committed
799
800
    get _ Empty               = Empty
    get _ NoDoc               = NoDoc
sof's avatar
sof committed
801
802
    get w (NilAbove p)        = nilAbove_ (get w p)
    get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
803
    get w (Nest k p)          = nest_ k (get (w -# k) p)
sof's avatar
sof committed
804
    get w (p `Union` q)       = nicest w r (get w p) (get w q)
Ian Lynagh's avatar
Ian Lynagh committed
805
    get _ _                   = panic "best/get: Unhandled case"
sof's avatar
sof committed
806

807
808
    get1 :: FastInt         -- (Remaining) width of line
         -> FastInt         -- Amount of first line already eaten up
sof's avatar
sof committed
809
810
         -> Doc         -- This is an argument to TextBeside => eat Nests
         -> Doc         -- No unions in here!
sof's avatar
sof committed
811

Ian Lynagh's avatar
Ian Lynagh committed
812
813
    get1 _ _  Empty               = Empty
    get1 _ _  NoDoc               = NoDoc
814
815
    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
816
    get1 w sl (Nest _ p)          = get1 w sl p
Ian Lynagh's avatar
Ian Lynagh committed
817
    get1 w sl (p `Union` q)       = nicest1 w r sl (get1 w sl p)
sof's avatar
sof committed
818
                                                   (get1 w sl q)
Ian Lynagh's avatar
Ian Lynagh committed
819
    get1 _ _  _                   = panic "best/get1: Unhandled case"
sof's avatar
sof committed
820

Ian Lynagh's avatar
Ian Lynagh committed
821
nicest :: FastInt -> FastInt -> Doc -> Doc -> Doc
822
nicest w r p q = nicest1 w r (_ILIT(0)) p q
Ian Lynagh's avatar
Ian Lynagh committed
823
nicest1 :: FastInt -> FastInt -> Int# -> Doc -> Doc -> Doc
824
nicest1 w r sl p q | fits ((w `minFastInt` r) -# sl) p = p
sof's avatar
sof committed
825
                   | otherwise                   = q
sof's avatar
sof committed
826

827
fits :: FastInt     -- Space available
sof's avatar
sof committed
828
     -> Doc
sof's avatar
sof committed
829
     -> Bool    -- True if *first line* of Doc fits in space available
Ian Lynagh's avatar
Ian Lynagh committed
830

Ian Lynagh's avatar
Ian Lynagh committed
831
832
833
834
fits n _   | n <# _ILIT(0) = False
fits _ NoDoc               = False
fits _ Empty               = True
fits _ (NilAbove _)        = True
835
fits n (TextBeside _ sl p) = fits (n -# sl) p
Ian Lynagh's avatar
Ian Lynagh committed
836
fits _ _                   = panic "fits: Unhandled case"
sof's avatar
sof committed
837
838
839
840
\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.
841

sof's avatar
sof committed
842
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
843
first :: Doc -> Doc -> Doc
Ian Lynagh's avatar
Ian Lynagh committed
844
first p q | nonEmptySet p = p
sof's avatar
sof committed
845
          | otherwise     = q
sof's avatar
sof committed
846

Ian Lynagh's avatar
Ian Lynagh committed
847
nonEmptySet :: Doc -> Bool
848
nonEmptySet NoDoc              = False
Ian Lynagh's avatar
Ian Lynagh committed
849
nonEmptySet (_ `Union` _)      = True
sof's avatar
sof committed
850
nonEmptySet Empty              = True
Ian Lynagh's avatar
Ian Lynagh committed
851
nonEmptySet (NilAbove _)       = True           -- NoDoc always in first line
sof's avatar
sof committed
852
853
nonEmptySet (TextBeside _ _ p) = nonEmptySet p
nonEmptySet (Nest _ p)         = nonEmptySet p
Ian Lynagh's avatar
Ian Lynagh committed
854
nonEmptySet _                  = panic "nonEmptySet: Unhandled case"
sof's avatar
sof committed
855
856
857
858
859
860
861
862
\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
863
oneLiner (NilAbove _)        = NoDoc
sof's avatar
sof committed
864
865
oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
oneLiner (Nest k p)          = nest_ k (oneLiner p)
Ian Lynagh's avatar
Ian Lynagh committed
866
867
oneLiner (p `Union` _)       = oneLiner p
oneLiner _                   = panic "oneLiner: Unhandled case"
868
869
870
\end{code}


sof's avatar
sof committed
871
872

*********************************************************
sof's avatar
sof committed
873
*                                                       *
sof's avatar
sof committed
874
\subsection{Displaying the best layout}
sof's avatar
sof committed
875
*                                                       *
sof's avatar
sof committed
876
877
*********************************************************

878
879

\begin{code}
sof's avatar
sof committed
880
{-
Ian Lynagh's avatar
Ian Lynagh committed
881
renderStyle Style{mode, lineLength, ribbonsPerLine} doc
sof's avatar
sof committed
882
883
  = fullRender mode lineLength ribbonsPerLine doc ""
-}
884

885
render doc       = showDocWith PageMode doc
Ian Lynagh's avatar
Ian Lynagh committed
886
887

showDoc :: Doc -> String -> String
888
889
890
891
892
893
894
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 ""
895

Ian Lynagh's avatar
Ian Lynagh committed
896
string_txt :: TextDetails -> String -> String
sof's avatar
sof committed
897
898
string_txt (Chr c)   s  = c:s
string_txt (Str s1)  s2 = s1 ++ s2
899
900
string_txt (PStr s1) s2 = unpackFS s1 ++ s2
string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
sof's avatar
sof committed
901
\end{code}
902

sof's avatar
sof committed
903
904
\begin{code}

Ian Lynagh's avatar
Ian Lynagh committed
905
fullRender OneLineMode _ _ txt end doc
906
907
  = lay (reduceDoc doc)
  where
Ian Lynagh's avatar
Ian Lynagh committed
908
909
910
911
912
913
914
915
    lay NoDoc              = cant_fail
    lay (Union _ q)        = lay q -- Second arg can't be NoDoc
    lay (Nest _ p)         = lay p
    lay Empty              = end
    lay (NilAbove p)       = space_text `txt` lay p -- NoDoc always on
                                                    -- first line
    lay (TextBeside s _ p) = s `txt` lay p
    lay _                  = panic "fullRender/OneLineMode/lay: Unhandled case"
916

Ian Lynagh's avatar
Ian Lynagh committed
917
fullRender LeftMode    _ _ txt end doc
918
919
  = lay (reduceDoc doc)
  where
Ian Lynagh's avatar
Ian Lynagh committed
920
921
922
923
924
925
926
    lay NoDoc              = cant_fail
    lay (Union p q)        = lay (first p q)
    lay (Nest _ p)         = lay p
    lay Empty              = end
    lay (NilAbove p)       = nl_text `txt` lay p -- NoDoc always on first line
    lay (TextBeside s _ p) = s `txt` lay p
    lay _                  = panic "fullRender/LeftMode/lay: Unhandled case"
sof's avatar
sof committed
927
928
929

fullRender mode line_length ribbons_per_line txt end doc
  = display mode line_length ribbon_length txt end best_doc
Ian Lynagh's avatar
Ian Lynagh committed
930
  where
931
    best_doc = best hacked_line_length ribbon_length (reduceDoc doc)
sof's avatar
sof committed
932
933

    hacked_line_length, ribbon_length :: Int
934
    ribbon_length = round (fromIntegral line_length / ribbons_per_line)
Ian Lynagh's avatar
Ian Lynagh committed
935
936
937
    hacked_line_length = case mode of
                         ZigZagMode -> maxBound
                         _ -> line_length
sof's avatar
sof committed
938

Ian Lynagh's avatar
Ian Lynagh committed
939
display :: Mode -> Int -> Int -> (TextDetails -> t -> t) -> t -> Doc -> t
940
941
942
display mode page_width ribbon_width txt end doc
  = case (iUnbox page_width) -# (iUnbox ribbon_width) of { gap_width ->
    case gap_width `quotFastInt` _ILIT(2) of { shift ->
sof's avatar
sof committed
943
    let
944
        lay k (Nest k1 p)  = lay (k +# k1) p
Ian Lynagh's avatar
Ian Lynagh committed
945
        lay _ Empty        = end
Ian Lynagh's avatar
Ian Lynagh committed
946

sof's avatar
sof committed
947
        lay k (NilAbove p) = nl_text `txt` lay k p
Ian Lynagh's avatar
Ian Lynagh committed
948

sof's avatar
sof committed
949
950
        lay k (TextBeside s sl p)
            = case mode of
951
                    ZigZagMode |  k >=# gap_width
sof's avatar
sof committed
952
953
954
                               -> nl_text `txt` (
                                  Str (multi_ch shift '/') `txt` (
                                  nl_text `txt` (
955
                                  lay1 (k -# shift) s sl p)))
sof's avatar
sof committed
956

957
                               |  k <# _ILIT(0)
sof's avatar
sof committed
958
959
960
                               -> nl_text `txt` (
                                  Str (multi_ch shift '\\') `txt` (
                                  nl_text `txt` (
961
                                  lay1 (k +# shift) s sl p )))
sof's avatar
sof committed
962

Ian Lynagh's avatar
Ian Lynagh committed
963
964
                    _ -> lay1 k s sl p
        lay _ _            = panic "display/lay: Unhandled case"
Ian Lynagh's avatar
Ian Lynagh committed
965

966
        lay1 k s sl p = indent k (s `txt` lay2 (k +# sl) p)
Ian Lynagh's avatar
Ian Lynagh committed
967

sof's avatar
sof committed
968
        lay2 k (NilAbove p)        = nl_text `txt` lay k p
969
        lay2 k (TextBeside s sl p) = s `txt` (lay2 (k +# sl) p)
sof's avatar
sof committed
970
        lay2 k (Nest _ p)          = lay2 k p
Ian Lynagh's avatar
Ian Lynagh committed
971
972
        lay2 _ Empty               = end
        lay2 _ _                   = panic "display/lay2: Unhandled case"
973
974

        -- optimise long indentations using LitString chunks of 8 spaces
Ian Lynagh's avatar
Ian Lynagh committed
975
        indent n r | n >=# _ILIT(8) = LStr (sLit "        ") (_ILIT(8)) `txt`
976
                                      indent (n -# _ILIT(8)) r
977
                   | otherwise      = Str (spaces n) `txt` r
sof's avatar
sof committed
978
    in
979
    lay (_ILIT(0)) doc
sof's avatar
sof committed
980
981
    }}

Ian Lynagh's avatar
Ian Lynagh committed
982
cant_fail :: a
sof's avatar
sof committed
983
984
cant_fail = error "easy_display: NoDoc"

Ian Lynagh's avatar
Ian Lynagh committed
985
multi_ch :: Int# -> Char -> String
986
multi_ch n ch | n <=# _ILIT(0) = ""
Ian Lynagh's avatar
Ian Lynagh committed
987
              | otherwise      = ch : multi_ch (n -# _ILIT(1)) ch
sof's avatar
sof committed
988

Ian Lynagh's avatar
Ian Lynagh committed
989
spaces :: Int# -> String
990
991
spaces n | n <=# _ILIT(0) = ""
         | otherwise      = ' ' : spaces (n -# _ILIT(1))
992

993
\end{code}