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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

  * Added $+$

  * Corrected and tidied up the laws and invariants

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

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

    It is Really Useful in practice.

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

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


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

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

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

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

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

        There are two places this is really useful

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

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

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

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

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


153
154

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

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

        empty, isEmpty, nest,

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

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

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

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

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

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

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

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


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

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

212
213
214
\end{code}


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

The primitive @Doc@ values
222
223

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

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

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

dreixel's avatar
dreixel committed
236
237
parens, brackets, braces    :: Doc -> Doc
quotes, quote, doubleQuotes :: Doc -> Doc
sof's avatar
sof committed
238

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

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

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

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

sof's avatar
sof committed
258
259
260
261
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
262

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

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

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

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

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

sof's avatar
sof committed
279
render     :: Doc -> String             -- Uses default style
sof's avatar
sof committed
280
fullRender :: Mode
sof's avatar
sof committed
281
282
283
284
285
286
287
           -> 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
288
{-      When we start using 1.3
sof's avatar
sof committed
289
renderStyle  :: Style -> Doc -> String
sof's avatar
sof committed
290
291
292
293
294
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
295
296
297
style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
-}

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

\end{code}

sof's avatar
sof committed
305

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

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

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

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

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

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

Laws for nest
~~~~~~~~~~~~~
sof's avatar
sof committed
337
338
339
340
341
342
<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
343

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

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

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


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

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

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


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



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

\begin{code}
sof's avatar
sof committed
392
393
394
395
396
397
398
399
400
401
402
403
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
404
int      n = text (show n)
sof's avatar
sof committed
405
406
407
integer  n = text (show n)
float    n = text (show n)
double   n = text (show n)
408
rational n = text (show (fromRat n :: Double))
sof's avatar
sof committed
409
--rational n = text (show (fromRationalX n)) -- _showRational 30 n)
sof's avatar
sof committed
410

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

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

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

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

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


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

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

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


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


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

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

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

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

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

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

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

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

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

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

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

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

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

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



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

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

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

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

568
#if defined(__GLASGOW_HASKELL__)
569
570
-- 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
571
{-# RULES
572
  "text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
573
 #-}
574
#endif
575

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

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

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

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

598
599

\begin{code}
sof's avatar
sof committed
600
p $$  q = Above p False q
Ian Lynagh's avatar
Ian Lynagh committed
601
($+$) :: Doc -> Doc -> Doc
sof's avatar
sof committed
602
603
604
605
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)
606
607
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
608

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

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

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

sof's avatar
sof committed
620
621
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
622
                                    where
623
                                      !k1  = k -# sl
sof's avatar
sof committed
624
625
                                      rest = case p of
                                                Empty -> nilAboveNest g k1 q
Ian Lynagh's avatar
Ian Lynagh committed
626
627
                                                _     -> aboveNest  p g k1 q
aboveNest _                   _ _ _ = panic "aboveNest: Unhandled case"
628
629
630
\end{code}

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

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

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


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

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

Ian Lynagh's avatar
Ian Lynagh committed
658
beside NoDoc               _ _   = NoDoc
sof's avatar
sof committed
659
beside (p1 `Union` p2)     g q   = (beside p1 g q) `union_` (beside p2 g q)
Ian Lynagh's avatar
Ian Lynagh committed
660
beside Empty               _ q   = q
661
beside (Nest k p)          g q   = nest_ k $! beside p g q       -- p non-empty
Ian Lynagh's avatar
Ian Lynagh committed
662
663
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
664
                                                 [ && (op1 == <> || op1 == <+>) ] -}
665
         | g1 == g2              = beside p1 g1 $! beside q1 g2 q2
sof's avatar
sof committed
666
         | otherwise             = beside (reduceDoc p) g2 q2
667
668
669
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
670
671
672
                               where
                                  rest = case p of
                                           Empty -> nilBeside g q
Ian Lynagh's avatar
Ian Lynagh committed
673
                                           _     -> beside p g q
674
675
676
\end{code}

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

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

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

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

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

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


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

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

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

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

-- 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
727
sepNB :: Bool -> Doc -> FastInt -> [Doc] -> Doc
sof's avatar
sof committed
728
729
730
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
731
                                `mkUnion`
sof's avatar
sof committed
732
733
734
735
                            nilAboveNest False k (reduceDoc (vcat ys))
                          where
                            rest | g         = hsep ys
                                 | otherwise = hcat ys
sof's avatar
sof committed
736

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

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

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

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

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


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

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

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

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

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

789

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

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

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

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

Ian Lynagh's avatar
Ian Lynagh committed
821
822
    get1 _ _  Empty               = Empty
    get1 _ _  NoDoc               = NoDoc
823
824
    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
825
    get1 w sl (Nest _ p)          = get1 w sl p
Ian Lynagh's avatar
Ian Lynagh committed
826
    get1 w sl (p `Union` q)       = nicest1 w r sl (get1 w sl p)
sof's avatar
sof committed
827
                                                   (get1 w sl q)
Ian Lynagh's avatar
Ian Lynagh committed
828
    get1 _ _  _                   = panic "best/get1: Unhandled case"
sof's avatar
sof committed
829

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

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

Ian Lynagh's avatar
Ian Lynagh committed
840
841
842
843
fits n _   | n <# _ILIT(0) = False
fits _ NoDoc               = False
fits _ Empty               = True
fits _ (NilAbove _)        = True
844
fits n (TextBeside _ sl p) = fits (n -# sl) p
Ian Lynagh's avatar
Ian Lynagh committed
845
fits _ _                   = panic "fits: Unhandled case"
sof's avatar
sof committed
846
847
848
849
\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.
850

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

Ian Lynagh's avatar
Ian Lynagh committed
856
nonEmptySet :: Doc -> Bool
857
nonEmptySet NoDoc              = False
Ian Lynagh's avatar
Ian Lynagh committed
858
nonEmptySet (_ `Union` _)      = True
sof's avatar
sof committed
859
nonEmptySet Empty              = True
Ian Lynagh's avatar
Ian Lynagh committed
860
nonEmptySet (NilAbove _)       = True           -- NoDoc always in first line
sof's avatar
sof committed
861
862
nonEmptySet (TextBeside _ _ p) = nonEmptySet p
nonEmptySet (Nest _ p)         = nonEmptySet p
Ian Lynagh's avatar
Ian Lynagh committed
863
nonEmptySet _                  = panic "nonEmptySet: Unhandled case"
sof's avatar
sof committed
864
865
866
867
868
869
870
871
\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
872
oneLiner (NilAbove _)        = NoDoc
sof's avatar
sof committed
873
874
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
875
876
oneLiner (p `Union` _)       = oneLiner p
oneLiner _                   = panic "oneLiner: Unhandled case"
877
878
879
\end{code}


sof's avatar
sof committed
880

Thomas Schilling's avatar
Thomas Schilling committed
881
882
%*********************************************************
%*                                                       *
sof's avatar
sof committed
883
\subsection{Displaying the best layout}
Thomas Schilling's avatar
Thomas Schilling committed
884
885
%*                                                       *
%*********************************************************
sof's avatar
sof committed
886

887
888

\begin{code}
sof's avatar
sof committed
889
{-
Ian Lynagh's avatar
Ian Lynagh committed
890
renderStyle Style{mode, lineLength, ribbonsPerLine} doc
sof's avatar
sof committed
891
892
  = fullRender mode lineLength ribbonsPerLine doc ""
-}
893

894
render doc       = showDocWith PageMode doc
Ian Lynagh's avatar
Ian Lynagh committed
895
896

showDoc :: Doc -> String -> String
897
898
899
900
901
902
903
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 ""
904

Ian Lynagh's avatar
Ian Lynagh committed
905
string_txt :: TextDetails -> String -> String
sof's avatar
sof committed
906
907
string_txt (Chr c)   s  = c:s
string_txt (Str s1)  s2 = s1 ++ s2
908
909
string_txt (PStr s1) s2 = unpackFS s1 ++ s2
string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
sof's avatar
sof committed
910
\end{code}
911

sof's avatar
sof committed
912
913
\begin{code}

Ian Lynagh's avatar
Ian Lynagh committed
914
fullRender OneLineMode _ _ txt end doc
915
916
  = lay (reduceDoc doc)
  where
Ian Lynagh's avatar
Ian Lynagh committed
917
918
919
920
921
922
923
924
    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"
925

Ian Lynagh's avatar
Ian Lynagh committed
926
fullRender LeftMode    _ _ txt end doc
927
928
  = lay (reduceDoc doc)
  where
Ian Lynagh's avatar
Ian Lynagh committed
929
930
931
932
933
934
935
    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
936
937
938

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
939
  where
940
    best_doc = best hacked_line_length ribbon_length (reduceDoc doc)
sof's avatar
sof committed
941
942

    hacked_line_length, ribbon_length :: Int
943
    ribbon_length = round (fromIntegral line_length / ribbons_per_line)
Ian Lynagh's avatar
Ian Lynagh committed
944
945
946
    hacked_line_length = case mode of
                         ZigZagMode -> maxBound
                         _ -> line_length
sof's avatar
sof committed
947

Ian Lynagh's avatar
Ian Lynagh committed
948
display :: Mode -> Int -> Int -> (TextDetails -> t -> t) -> t -> Doc -> t
949
950
951
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
952
    let
953
        lay k (Nest k1 p)  = lay (k +# k1) p
Ian Lynagh's avatar
Ian Lynagh committed
954
        lay _ Empty        = end
Ian Lynagh's avatar
Ian Lynagh committed
955

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

sof's avatar
sof committed
958
959
        lay k (TextBeside s sl p)
            = case mode of
960
                    ZigZagMode |  k >=# gap_width
sof's avatar
sof committed
961
962
963
                               -> nl_text `txt` (
                                  Str (multi_ch shift '/') `txt` (
                                  nl_text `txt` (
964
                                  lay1 (k -# shift) s sl p)))
sof's avatar
sof committed
965

966
                               |  k <# _ILIT(0)
sof's avatar
sof committed
967
968
969
                               -> nl_text `txt` (
                                  Str (multi_ch shift '\\') `txt` (
                                  nl_text `txt` (
970
                                  lay1 (k +# shift) s sl p )))
sof's avatar
sof committed
971

Ian Lynagh's avatar
Ian Lynagh committed
972
973
                    _ -> lay1 k s sl p
        lay _ _            = panic "display/lay: Unhandled case"
Ian Lynagh's avatar
Ian Lynagh committed
974

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

sof's avatar
sof committed
977
        lay2 k (NilAbove p)        = nl_text `txt` lay k p
978
        lay2 k (TextBeside s sl p) = s `txt` (lay2 (k +# sl) p)
sof's avatar
sof committed
979
        lay2 k (Nest _ p)          = lay2 k p
Ian Lynagh's avatar
Ian Lynagh committed
980
981
        lay2 _ Empty               = end
        lay2 _ _                   = panic "display/lay2: Unhandled case"
982
983

        -- optimise long indentations using LitString chunks of 8 spaces
Ian Lynagh's avatar
Ian Lynagh committed
984
        indent n r | n >=# _ILIT(8) = LStr (sLit "        ") (_ILIT(8)) `txt`
985
                                      indent (n -# _ILIT(8)) r
986