FIX BUILD with GHC 6.2.x: VectInfo -> HscTypes.VectInfo
[ghc-hetmet.git] / compiler / utils / Pretty.lhs
1 *********************************************************************************
2 *                                                                               *
3 *       John Hughes's and Simon Peyton Jones's Pretty Printer Combinators       *
4 *                                                                               *
5 *               based on "The Design of a Pretty-printing Library"              *
6 *               in Advanced Functional Programming,                             *
7 *               Johan Jeuring and Erik Meijer (eds), LNCS 925                   *
8 *               http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps                *
9 *                                                                               *
10 *               Heavily modified by Simon Peyton Jones, Dec 96                  *
11 *                                                                               *
12 *********************************************************************************
13
14 Version 3.0     28 May 1997
15   * Cured massive performance bug.  If you write
16
17         foldl <> empty (map (text.show) [1..10000])
18
19     you get quadratic behaviour with V2.0.  Why?  For just the same reason as you get
20     quadratic behaviour with left-associated (++) chains.
21
22     This is really bad news.  One thing a pretty-printer abstraction should
23     certainly guarantee is insensivity to associativity.  It matters: suddenly
24     GHC's compilation times went up by a factor of 100 when I switched to the
25     new pretty printer.
26  
27     I fixed it with a bit of a hack (because I wanted to get GHC back on the
28     road).  I added two new constructors to the Doc type, Above and Beside:
29  
30          <> = Beside
31          $$ = Above
32  
33     Then, where I need to get to a "TextBeside" or "NilAbove" form I "force"
34     the Doc to squeeze out these suspended calls to Beside and Above; but in so
35     doing I re-associate. It's quite simple, but I'm not satisfied that I've done
36     the best possible job.  I'll send you the code if you are interested.
37
38   * Added new exports:
39         punctuate, hang
40         int, integer, float, double, rational,
41         lparen, rparen, lbrack, rbrack, lbrace, rbrace,
42
43   * fullRender's type signature has changed.  Rather than producing a string it
44     now takes an extra couple of arguments that tells it how to glue fragments
45     of output together:
46
47         fullRender :: Mode
48                    -> Int                       -- Line length
49                    -> Float                     -- Ribbons per line
50                    -> (TextDetails -> a -> a)   -- What to do with text
51                    -> a                         -- What to do at the end
52                    -> Doc
53                    -> a                         -- Result
54
55     The "fragments" are encapsulated in the TextDetails data type:
56         data TextDetails = Chr  Char
57                          | Str  String
58                          | PStr FastString
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.
62
63     An advantage of this new setup is that you can get the renderer to do output
64     directly (by passing in a function of type (TextDetails -> IO () -> IO ()),
65     rather than producing a string that you then print.
66
67
68 Version 2.0     24 April 1997
69   * Made empty into a left unit for <> as well as a right unit;
70     it is also now true that
71         nest k empty = empty
72     which wasn't true before.
73
74   * Fixed an obscure bug in sep that occassionally gave very wierd behaviour
75
76   * Added $+$
77
78   * Corrected and tidied up the laws and invariants
79
80 ======================================================================
81 Relative to John's original paper, there are the following new features:
82
83 1.  There's an empty document, "empty".  It's a left and right unit for 
84     both <> and $$, and anywhere in the argument list for
85     sep, hcat, hsep, vcat, fcat etc.
86
87     It is Really Useful in practice.
88
89 2.  There is a paragraph-fill combinator, fsep, that's much like sep,
90     only it keeps fitting things on one line until itc can't fit any more.
91
92 3.  Some random useful extra combinators are provided.  
93         <+> puts its arguments beside each other with a space between them,
94             unless either argument is empty in which case it returns the other
95
96
97         hcat is a list version of <>
98         hsep is a list version of <+>
99         vcat is a list version of $$
100
101         sep (separate) is either like hsep or like vcat, depending on what fits
102
103         cat  is behaves like sep,  but it uses <> for horizontal conposition
104         fcat is behaves like fsep, but it uses <> for horizontal conposition
105
106         These new ones do the obvious things:
107                 char, semi, comma, colon, space,
108                 parens, brackets, braces, 
109                 quotes, doubleQuotes
110         
111 4.      The "above" combinator, $$, now overlaps its two arguments if the
112         last line of the top argument stops before the first line of the second begins.
113         For example:  text "hi" $$ nest 5 "there"
114         lays out as
115                         hi   there
116         rather than
117                         hi
118                              there
119
120         There are two places this is really useful
121
122         a) When making labelled blocks, like this:
123                 Left ->   code for left
124                 Right ->  code for right
125                 LongLongLongLabel ->
126                           code for longlonglonglabel
127            The block is on the same line as the label if the label is
128            short, but on the next line otherwise.
129
130         b) When laying out lists like this:
131                 [ first
132                 , second
133                 , third
134                 ]
135            which some people like.  But if the list fits on one line
136            you want [first, second, third].  You can't do this with
137            John's original combinators, but it's quite easy with the
138            new $$.
139
140         The combinator $+$ gives the original "never-overlap" behaviour.
141
142 5.      Several different renderers are provided:
143                 * a standard one
144                 * one that uses cut-marks to avoid deeply-nested documents 
145                         simply piling up in the right-hand margin
146                 * one that ignores indentation (fewer chars output; good for machines)
147                 * one that ignores indentation and newlines (ditto, only more so)
148
149 6.      Numerous implementation tidy-ups
150         Use of unboxed data types to speed up the implementation
151
152
153
154 \begin{code}
155 module Pretty (
156         Doc,            -- Abstract
157         Mode(..), TextDetails(..),
158
159         empty, isEmpty, nest,
160
161         text, char, ftext, ptext,
162         int, integer, float, double, rational,
163         parens, brackets, braces, quotes, doubleQuotes,
164         semi, comma, colon, space, equals,
165         lparen, rparen, lbrack, rbrack, lbrace, rbrace, cparen,
166
167         (<>), (<+>), hcat, hsep, 
168         ($$), ($+$), vcat, 
169         sep, cat, 
170         fsep, fcat, 
171
172         hang, punctuate,
173         
174 --      renderStyle,            -- Haskell 1.3 only
175         render, fullRender, printDoc, showDocWith
176   ) where
177
178 #include "HsVersions.h"
179
180 import BufWrite
181 import FastString
182
183 import GHC.Exts
184
185 import Numeric (fromRat)
186 import System.IO
187
188 import GHC.Base         ( unpackCString# )
189 import GHC.Ptr          ( Ptr(..) )
190
191 -- Don't import Util( assertPanic ) because it makes a loop in the module structure
192
193 infixl 6 <> 
194 infixl 6 <+>
195 infixl 5 $$, $+$
196 \end{code}
197
198
199
200 *********************************************************
201 *                                                       *
202 \subsection{CPP magic so that we can compile with both GHC and Hugs}
203 *                                                       *
204 *********************************************************
205
206 The library uses unboxed types to get a bit more speed, but these CPP macros
207 allow you to use either GHC or Hugs.  To get GHC, just set the CPP variable
208         __GLASGOW_HASKELL__
209
210 \begin{code}
211
212 #if defined(__GLASGOW_HASKELL__)
213
214 -- Glasgow Haskell
215
216 -- Disable ASSERT checks; they are expensive!
217 #define LOCAL_ASSERT(x)
218
219 #define ILIT(x) (x#)
220 #define IBOX(x) (I# (x))
221 #define INT     Int#
222 #define MINUS   -#
223 #define NEGATE  negateInt#
224 #define PLUS    +#
225 #define GR      >#
226 #define GREQ    >=#
227 #define LT      <#
228 #define LTEQ    <=#
229 #define DIV     `quotInt#`
230
231
232 #define SHOW    Show
233 #define MAXINT  maxBound
234
235 #else
236
237 -- Standard Haskell
238
239 #define LOCAL_ASSERT(x)
240
241 #define INT     Int
242 #define IBOX(x) x
243 #define MINUS   -
244 #define NEGATE  negate
245 #define PLUS    +
246 #define GR      >
247 #define GREQ    >=
248 #define LT      <
249 #define DIV     `quot`
250 #define ILIT(x) x
251
252 #define SHOW    Show
253 #define MAXINT  maxBound
254
255 #endif
256
257 \end{code}
258
259
260 *********************************************************
261 *                                                       *
262 \subsection{The interface}
263 *                                                       *
264 *********************************************************
265
266 The primitive @Doc@ values
267
268 \begin{code}
269 empty                     :: Doc
270 isEmpty                   :: Doc    -> Bool
271 text                      :: String -> Doc 
272 char                      :: Char -> Doc
273
274 semi, comma, colon, space, equals              :: Doc
275 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
276
277 parens, brackets, braces  :: Doc -> Doc 
278 quotes, doubleQuotes      :: Doc -> Doc
279
280 int      :: Int -> Doc
281 integer  :: Integer -> Doc
282 float    :: Float -> Doc
283 double   :: Double -> Doc
284 rational :: Rational -> Doc
285 \end{code}
286
287 Combining @Doc@ values
288
289 \begin{code}
290 (<>)   :: Doc -> Doc -> Doc     -- Beside
291 hcat   :: [Doc] -> Doc          -- List version of <>
292 (<+>)  :: Doc -> Doc -> Doc     -- Beside, separated by space
293 hsep   :: [Doc] -> Doc          -- List version of <+>
294
295 ($$)   :: Doc -> Doc -> Doc     -- Above; if there is no
296                                 -- overlap it "dovetails" the two
297 vcat   :: [Doc] -> Doc          -- List version of $$
298
299 cat    :: [Doc] -> Doc          -- Either hcat or vcat
300 sep    :: [Doc] -> Doc          -- Either hsep or vcat
301 fcat   :: [Doc] -> Doc          -- ``Paragraph fill'' version of cat
302 fsep   :: [Doc] -> Doc          -- ``Paragraph fill'' version of sep
303
304 nest   :: Int -> Doc -> Doc     -- Nested
305 \end{code}
306
307 GHC-specific ones.
308
309 \begin{code}
310 hang :: Doc -> Int -> Doc -> Doc
311 punctuate :: Doc -> [Doc] -> [Doc]      -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
312 \end{code}
313
314 Displaying @Doc@ values. 
315
316 \begin{code}
317 instance SHOW Doc where
318   showsPrec prec doc cont = showDoc doc cont
319
320 render     :: Doc -> String             -- Uses default style
321 fullRender :: Mode
322            -> Int                       -- Line length
323            -> Float                     -- Ribbons per line
324            -> (TextDetails -> a -> a)   -- What to do with text
325            -> a                         -- What to do at the end
326            -> Doc
327            -> a                         -- Result
328
329 {-      When we start using 1.3 
330 renderStyle  :: Style -> Doc -> String
331 data Style = Style { lineLength     :: Int,     -- In chars
332                      ribbonsPerLine :: Float,   -- Ratio of ribbon length to line length
333                      mode :: Mode
334              }
335 style :: Style          -- The default style
336 style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
337 -}
338
339 data Mode = PageMode            -- Normal 
340           | ZigZagMode          -- With zig-zag cuts
341           | LeftMode            -- No indentation, infinitely long lines
342           | OneLineMode         -- All on one line
343
344 \end{code}
345
346
347 *********************************************************
348 *                                                       *
349 \subsection{The @Doc@ calculus}
350 *                                                       *
351 *********************************************************
352
353 The @Doc@ combinators satisfy the following laws:
354 \begin{verbatim}
355 Laws for $$
356 ~~~~~~~~~~~
357 <a1>    (x $$ y) $$ z   = x $$ (y $$ z)
358 <a2>    empty $$ x      = x
359 <a3>    x $$ empty      = x
360
361         ...ditto $+$...
362
363 Laws for <>
364 ~~~~~~~~~~~
365 <b1>    (x <> y) <> z   = x <> (y <> z)
366 <b2>    empty <> x      = empty
367 <b3>    x <> empty      = x
368
369         ...ditto <+>...
370
371 Laws for text
372 ~~~~~~~~~~~~~
373 <t1>    text s <> text t        = text (s++t)
374 <t2>    text "" <> x            = x, if x non-empty
375
376 Laws for nest
377 ~~~~~~~~~~~~~
378 <n1>    nest 0 x                = x
379 <n2>    nest k (nest k' x)      = nest (k+k') x
380 <n3>    nest k (x <> y)         = nest k z <> nest k y
381 <n4>    nest k (x $$ y)         = nest k x $$ nest k y
382 <n5>    nest k empty            = empty
383 <n6>    x <> nest k y           = x <> y, if x non-empty
384
385 ** Note the side condition on <n6>!  It is this that
386 ** makes it OK for empty to be a left unit for <>.
387
388 Miscellaneous
389 ~~~~~~~~~~~~~
390 <m1>    (text s <> x) $$ y = text s <> ((text "" <> x)) $$ 
391                                          nest (-length s) y)
392
393 <m2>    (x $$ y) <> z = x $$ (y <> z)
394         if y non-empty
395
396
397 Laws for list versions
398 ~~~~~~~~~~~~~~~~~~~~~~
399 <l1>    sep (ps++[empty]++qs)   = sep (ps ++ qs)
400         ...ditto hsep, hcat, vcat, fill...
401
402 <l2>    nest k (sep ps) = sep (map (nest k) ps)
403         ...ditto hsep, hcat, vcat, fill...
404
405 Laws for oneLiner
406 ~~~~~~~~~~~~~~~~~
407 <o1>    oneLiner (nest k p) = nest k (oneLiner p)
408 <o2>    oneLiner (x <> y)   = oneLiner x <> oneLiner y 
409 \end{verbatim}
410
411
412 You might think that the following verion of <m1> would
413 be neater:
414 \begin{verbatim}
415 <3 NO>  (text s <> x) $$ y = text s <> ((empty <> x)) $$ 
416                                          nest (-length s) y)
417 \end{verbatim}
418 But it doesn't work, for if x=empty, we would have
419 \begin{verbatim}
420         text s $$ y = text s <> (empty $$ nest (-length s) y)
421                     = text s <> nest (-length s) y
422 \end{verbatim}
423
424
425
426 *********************************************************
427 *                                                       *
428 \subsection{Simple derived definitions}
429 *                                                       *
430 *********************************************************
431
432 \begin{code}
433 semi  = char ';'
434 colon = char ':'
435 comma = char ','
436 space = char ' '
437 equals = char '='
438 lparen = char '('
439 rparen = char ')'
440 lbrack = char '['
441 rbrack = char ']'
442 lbrace = char '{'
443 rbrace = char '}'
444
445 int      n = text (show n)
446 integer  n = text (show n)
447 float    n = text (show n)
448 double   n = text (show n)
449 rational n = text (show (fromRat n))
450 --rational n = text (show (fromRationalX n)) -- _showRational 30 n)
451
452 quotes p        = char '`' <> p <> char '\''
453 doubleQuotes p  = char '"' <> p <> char '"'
454 parens p        = char '(' <> p <> char ')'
455 brackets p      = char '[' <> p <> char ']'
456 braces p        = char '{' <> p <> char '}'
457
458 cparen True  = parens
459 cparen False = id
460
461 hcat = foldr (<>)  empty
462 hsep = foldr (<+>) empty
463 vcat = foldr ($$)  empty
464
465 hang d1 n d2 = sep [d1, nest n d2]
466
467 punctuate p []     = []
468 punctuate p (d:ds) = go d ds
469                    where
470                      go d [] = [d]
471                      go d (e:es) = (d <> p) : go e es
472 \end{code}
473
474
475 *********************************************************
476 *                                                       *
477 \subsection{The @Doc@ data type}
478 *                                                       *
479 *********************************************************
480
481 A @Doc@ represents a {\em set} of layouts.  A @Doc@ with
482 no occurrences of @Union@ or @NoDoc@ represents just one layout.
483 \begin{code}
484 data Doc
485  = Empty                                -- empty
486  | NilAbove Doc                         -- text "" $$ x
487  | TextBeside !TextDetails INT Doc       -- text s <> x  
488  | Nest INT Doc                         -- nest k x
489  | Union Doc Doc                        -- ul `union` ur
490  | NoDoc                                -- The empty set of documents
491  | Beside Doc Bool Doc                  -- True <=> space between
492  | Above  Doc Bool Doc                  -- True <=> never overlap
493
494 type RDoc = Doc         -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
495
496
497 reduceDoc :: Doc -> RDoc
498 reduceDoc (Beside p g q) = beside p g (reduceDoc q)
499 reduceDoc (Above  p g q) = above  p g (reduceDoc q)
500 reduceDoc p              = p
501
502
503 data TextDetails = Chr  {-#UNPACK#-}!Char
504                  | Str  String
505                  | PStr FastString      -- a hashed string
506                  | LStr Addr# Int#      -- a '\0'-terminated array of bytes
507
508 space_text = Chr ' '
509 nl_text    = Chr '\n'
510 \end{code}
511
512 Here are the invariants:
513 \begin{itemize}
514 \item
515 The argument of @NilAbove@ is never @Empty@. Therefore
516 a @NilAbove@ occupies at least two lines.
517
518 \item
519 The arugment of @TextBeside@ is never @Nest@.
520
521 \item 
522 The layouts of the two arguments of @Union@ both flatten to the same string.
523
524 \item 
525 The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
526
527 \item
528 The right argument of a union cannot be equivalent to the empty set (@NoDoc@).
529 If the left argument of a union is equivalent to the empty set (@NoDoc@),
530 then the @NoDoc@ appears in the first line.
531
532 \item 
533 An empty document is always represented by @Empty@.
534 It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.
535
536 \item 
537 The first line of every layout in the left argument of @Union@
538 is longer than the first line of any layout in the right argument.
539 (1) ensures that the left argument has a first line.  In view of (3),
540 this invariant means that the right argument must have at least two
541 lines.
542 \end{itemize}
543
544 \begin{code}
545         -- Arg of a NilAbove is always an RDoc
546 nilAbove_ p = LOCAL_ASSERT( ok p ) NilAbove p
547             where
548               ok Empty = False
549               ok other = True
550
551         -- Arg of a TextBeside is always an RDoc
552 textBeside_ s sl p = TextBeside s sl (LOCAL_ASSERT( ok p ) p)
553                    where
554                      ok (Nest _ _) = False
555                      ok other      = True
556
557         -- Arg of Nest is always an RDoc
558 nest_ k p = Nest k (LOCAL_ASSERT( ok p ) p)
559           where
560             ok Empty = False
561             ok other = True
562
563         -- Args of union are always RDocs
564 union_ p q = Union (LOCAL_ASSERT( ok p ) p) (LOCAL_ASSERT( ok q ) q)
565            where
566              ok (TextBeside _ _ _) = True
567              ok (NilAbove _)       = True
568              ok (Union _ _)        = True
569              ok other              = False
570 \end{code}
571
572
573 Notice the difference between
574         * NoDoc (no documents)
575         * Empty (one empty document; no height and no width)
576         * text "" (a document containing the empty string;
577                    one line high, but has no width)
578
579
580
581 *********************************************************
582 *                                                       *
583 \subsection{@empty@, @text@, @nest@, @union@}
584 *                                                       *
585 *********************************************************
586
587 \begin{code}
588 empty = Empty
589
590 isEmpty Empty = True
591 isEmpty _     = False
592
593 char  c = textBeside_ (Chr c) 1# Empty
594 text  s = case length   s of {IBOX(sl) -> textBeside_ (Str s)  sl Empty}
595 ftext s = case lengthFS s of {IBOX(sl) -> textBeside_ (PStr s) sl Empty}
596 ptext (Ptr s) = case strLength (Ptr s) of {IBOX(sl) -> textBeside_ (LStr s sl) sl Empty}
597
598 -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
599 -- intermediate packing/unpacking of the string.
600 {-# RULES 
601   "text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
602  #-}
603
604 nest IBOX(k)  p = mkNest k (reduceDoc p)        -- Externally callable version
605
606 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
607 mkNest k       (Nest k1 p) = mkNest (k PLUS k1) p
608 mkNest k       NoDoc       = NoDoc
609 mkNest k       Empty       = Empty
610 mkNest ILIT(0) p           = p                  -- Worth a try!
611 mkNest k       p           = nest_ k p
612
613 -- mkUnion checks for an empty document
614 mkUnion Empty q = Empty
615 mkUnion p q     = p `union_` q
616 \end{code}
617
618 *********************************************************
619 *                                                       *
620 \subsection{Vertical composition @$$@}
621 *                                                       *
622 *********************************************************
623
624
625 \begin{code}
626 p $$  q = Above p False q
627 p $+$ q = Above p True q
628
629 above :: Doc -> Bool -> RDoc -> RDoc
630 above (Above p g1 q1)  g2 q2 = above p g1 (above q1 g2 q2)
631 above p@(Beside _ _ _) g  q  = aboveNest (reduceDoc p) g ILIT(0) (reduceDoc q)
632 above p g q                  = aboveNest p             g ILIT(0) (reduceDoc q)
633
634 aboveNest :: RDoc -> Bool -> INT -> RDoc -> RDoc
635 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
636
637 aboveNest NoDoc               g k q = NoDoc
638 aboveNest (p1 `Union` p2)     g k q = aboveNest p1 g k q `union_` 
639                                       aboveNest p2 g k q
640                                 
641 aboveNest Empty               g k q = mkNest k q
642 aboveNest (Nest k1 p)         g k q = nest_ k1 (aboveNest p g (k MINUS k1) q)
643                                   -- p can't be Empty, so no need for mkNest
644                                 
645 aboveNest (NilAbove p)        g k q = nilAbove_ (aboveNest p g k q)
646 aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
647                                     where
648                                       k1   = k MINUS sl
649                                       rest = case p of
650                                                 Empty -> nilAboveNest g k1 q
651                                                 other -> aboveNest  p g k1 q
652 \end{code}
653
654 \begin{code}
655 nilAboveNest :: Bool -> INT -> RDoc -> RDoc
656 -- Specification: text s <> nilaboveNest g k q 
657 --              = text s <> (text "" $g$ nest k q)
658
659 nilAboveNest g k Empty       = Empty    -- Here's why the "text s <>" is in the spec!
660 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k PLUS k1) q
661
662 nilAboveNest g k q           | (not g) && (k GR ILIT(0))        -- No newline if no overlap
663                              = textBeside_ (Str (spaces k)) k q
664                              | otherwise                        -- Put them really above
665                              = nilAbove_ (mkNest k q)
666 \end{code}
667
668
669 *********************************************************
670 *                                                       *
671 \subsection{Horizontal composition @<>@}
672 *                                                       *
673 *********************************************************
674
675 \begin{code}
676 p <>  q = Beside p False q
677 p <+> q = Beside p True  q
678
679 beside :: Doc -> Bool -> RDoc -> RDoc
680 -- Specification: beside g p q = p <g> q
681  
682 beside NoDoc               g q   = NoDoc
683 beside (p1 `Union` p2)     g q   = (beside p1 g q) `union_` (beside p2 g q)
684 beside Empty               g q   = q
685 beside (Nest k p)          g q   = nest_ k $! beside p g q       -- p non-empty
686 beside p@(Beside p1 g1 q1) g2 q2 
687            {- (A `op1` B) `op2` C == A `op1` (B `op2` C)  iff op1 == op2 
688                                                  [ && (op1 == <> || op1 == <+>) ] -}
689          | g1 == g2              = beside p1 g1 $! beside q1 g2 q2
690          | otherwise             = beside (reduceDoc p) g2 q2
691 beside p@(Above _ _ _)     g q   = let d = reduceDoc p in d `seq` beside d g q
692 beside (NilAbove p)        g q   = nilAbove_ $! beside p g q
693 beside (TextBeside s sl p) g q   = textBeside_ s sl $! rest
694                                where
695                                   rest = case p of
696                                            Empty -> nilBeside g q
697                                            other -> beside p g q
698 \end{code}
699
700 \begin{code}
701 nilBeside :: Bool -> RDoc -> RDoc
702 -- Specification: text "" <> nilBeside g p 
703 --              = text "" <g> p
704
705 nilBeside g Empty      = Empty  -- Hence the text "" in the spec
706 nilBeside g (Nest _ p) = nilBeside g p
707 nilBeside g p          | g         = textBeside_ space_text ILIT(1) p
708                        | otherwise = p
709 \end{code}
710
711 *********************************************************
712 *                                                       *
713 \subsection{Separate, @sep@, Hughes version}
714 *                                                       *
715 *********************************************************
716
717 \begin{code}
718 -- Specification: sep ps  = oneLiner (hsep ps)
719 --                         `union`
720 --                          vcat ps
721
722 sep = sepX True         -- Separate with spaces
723 cat = sepX False        -- Don't
724
725 sepX x []     = empty
726 sepX x (p:ps) = sep1 x (reduceDoc p) ILIT(0) ps
727
728
729 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
730 --                            = oneLiner (x <g> nest k (hsep ys))
731 --                              `union` x $$ nest k (vcat ys)
732
733 sep1 :: Bool -> RDoc -> INT -> [Doc] -> RDoc
734 sep1 g NoDoc               k ys = NoDoc
735 sep1 g (p `Union` q)       k ys = sep1 g p k ys
736                                   `union_`
737                                   (aboveNest q False k (reduceDoc (vcat ys)))
738
739 sep1 g Empty               k ys = mkNest k (sepX g ys)
740 sep1 g (Nest n p)          k ys = nest_ n (sep1 g p (k MINUS n) ys)
741
742 sep1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
743 sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k MINUS sl) ys)
744
745 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
746 -- Called when we have already found some text in the first item
747 -- We have to eat up nests
748
749 sepNB g (Nest _ p)  k ys  = sepNB g p k ys
750
751 sepNB g Empty k ys        = oneLiner (nilBeside g (reduceDoc rest))
752                                 `mkUnion` 
753                             nilAboveNest False k (reduceDoc (vcat ys))
754                           where
755                             rest | g         = hsep ys
756                                  | otherwise = hcat ys
757
758 sepNB g p k ys            = sep1 g p k ys
759 \end{code}
760
761 *********************************************************
762 *                                                       *
763 \subsection{@fill@}
764 *                                                       *
765 *********************************************************
766
767 \begin{code}
768 fsep = fill True
769 fcat = fill False
770
771 -- Specification: 
772 --   fill []  = empty
773 --   fill [p] = p
774 --   fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) 
775 --                                          (fill (oneLiner p2 : ps))
776 --                     `union`
777 --                      p1 $$ fill ps
778
779 fill g []     = empty
780 fill g (p:ps) = fill1 g (reduceDoc p) ILIT(0) ps
781
782
783 fill1 :: Bool -> RDoc -> INT -> [Doc] -> Doc
784 fill1 g NoDoc               k ys = NoDoc
785 fill1 g (p `Union` q)       k ys = fill1 g p k ys
786                                    `union_`
787                                    (aboveNest q False k (fill g ys))
788
789 fill1 g Empty               k ys = mkNest k (fill g ys)
790 fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k MINUS n) ys)
791
792 fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fill g ys))
793 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k MINUS sl) ys)
794
795 fillNB g (Nest _ p)  k ys  = fillNB g p k ys
796 fillNB g Empty k []        = Empty
797 fillNB g Empty k (y:ys)    = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
798                              `mkUnion` 
799                              nilAboveNest False k (fill g (y:ys))
800                            where
801                              k1 | g         = k MINUS ILIT(1)
802                                 | otherwise = k
803
804 fillNB g p k ys            = fill1 g p k ys
805 \end{code}
806
807
808 *********************************************************
809 *                                                       *
810 \subsection{Selecting the best layout}
811 *                                                       *
812 *********************************************************
813
814 \begin{code}
815 best :: Int             -- Line length
816      -> Int             -- Ribbon length
817      -> RDoc
818      -> RDoc            -- No unions in here!
819
820 best IBOX(w) IBOX(r) p
821   = get w p
822   where
823     get :: INT          -- (Remaining) width of line
824         -> Doc -> Doc
825     get w Empty               = Empty
826     get w NoDoc               = NoDoc
827     get w (NilAbove p)        = nilAbove_ (get w p)
828     get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
829     get w (Nest k p)          = nest_ k (get (w MINUS k) p)
830     get w (p `Union` q)       = nicest w r (get w p) (get w q)
831
832     get1 :: INT         -- (Remaining) width of line
833          -> INT         -- Amount of first line already eaten up
834          -> Doc         -- This is an argument to TextBeside => eat Nests
835          -> Doc         -- No unions in here!
836
837     get1 w sl Empty               = Empty
838     get1 w sl NoDoc               = NoDoc
839     get1 w sl (NilAbove p)        = nilAbove_ (get (w MINUS sl) p)
840     get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl PLUS tl) p)
841     get1 w sl (Nest k p)          = get1 w sl p
842     get1 w sl (p `Union` q)       = nicest1 w r sl (get1 w sl p) 
843                                                    (get1 w sl q)
844
845 nicest w r p q = nicest1 w r ILIT(0) p q
846 nicest1 w r sl p q | fits ((w `minn` r) MINUS sl) p = p
847                    | otherwise                   = q
848
849 fits :: INT     -- Space available
850      -> Doc
851      -> Bool    -- True if *first line* of Doc fits in space available
852  
853 fits n p    | n LT ILIT(0) = False
854 fits n NoDoc               = False
855 fits n Empty               = True
856 fits n (NilAbove _)        = True
857 fits n (TextBeside _ sl p) = fits (n MINUS sl) p
858
859 minn x y | x LT y    = x
860          | otherwise = y
861 \end{code}
862
863 @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
864 @first@ returns its first argument if it is non-empty, otherwise its second.
865
866 \begin{code}
867 first p q | nonEmptySet p = p 
868           | otherwise     = q
869
870 nonEmptySet NoDoc              = False
871 nonEmptySet (p `Union` q)      = True
872 nonEmptySet Empty              = True
873 nonEmptySet (NilAbove p)       = True           -- NoDoc always in first line
874 nonEmptySet (TextBeside _ _ p) = nonEmptySet p
875 nonEmptySet (Nest _ p)         = nonEmptySet p
876 \end{code}
877
878 @oneLiner@ returns the one-line members of the given set of @Doc@s.
879
880 \begin{code}
881 oneLiner :: Doc -> Doc
882 oneLiner NoDoc               = NoDoc
883 oneLiner Empty               = Empty
884 oneLiner (NilAbove p)        = NoDoc
885 oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
886 oneLiner (Nest k p)          = nest_ k (oneLiner p)
887 oneLiner (p `Union` q)       = oneLiner p
888 \end{code}
889
890
891
892 *********************************************************
893 *                                                       *
894 \subsection{Displaying the best layout}
895 *                                                       *
896 *********************************************************
897
898
899 \begin{code}
900 {-
901 renderStyle Style{mode, lineLength, ribbonsPerLine} doc 
902   = fullRender mode lineLength ribbonsPerLine doc ""
903 -}
904
905 render doc       = showDocWith PageMode doc
906 showDoc doc rest = showDocWithAppend PageMode doc rest
907
908 showDocWithAppend :: Mode -> Doc -> String -> String
909 showDocWithAppend mode doc rest = fullRender mode 100 1.5 string_txt rest doc
910
911 showDocWith :: Mode -> Doc -> String
912 showDocWith mode doc = showDocWithAppend mode doc ""
913
914 string_txt (Chr c)   s  = c:s
915 string_txt (Str s1)  s2 = s1 ++ s2
916 string_txt (PStr s1) s2 = unpackFS s1 ++ s2
917 string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
918
919 unpackLitString addr =
920  unpack 0#
921  where
922     unpack nh
923       | ch `eqChar#` '\0'# = []
924       | otherwise   = C# ch : unpack (nh +# 1#)
925       where
926         ch = indexCharOffAddr# addr nh
927 \end{code}
928
929 \begin{code}
930
931 fullRender OneLineMode _ _ txt end doc 
932   = lay (reduceDoc doc)
933   where
934     lay NoDoc               = cant_fail
935     lay (Union p q)         = (lay q)                   -- Second arg can't be NoDoc
936     lay (Nest k p)          = lay p
937     lay Empty               = end
938     lay (NilAbove p)        = space_text `txt` lay p    -- NoDoc always on first line
939     lay (TextBeside s sl p) = s `txt` lay p
940
941 fullRender LeftMode    _ _ txt end doc 
942   = lay (reduceDoc doc)
943   where
944     lay NoDoc                   = cant_fail
945     lay (Union p q)             = lay (first p q)
946     lay (Nest k p)              = lay p
947     lay Empty                   = end
948     lay (NilAbove p)            = nl_text `txt` lay p   -- NoDoc always on first line
949     lay (TextBeside s sl p)     = s `txt` lay p
950
951 fullRender mode line_length ribbons_per_line txt end doc
952   = display mode line_length ribbon_length txt end best_doc
953   where 
954     best_doc = best hacked_line_length ribbon_length (reduceDoc doc)
955
956     hacked_line_length, ribbon_length :: Int
957     ribbon_length = round (fromIntegral line_length / ribbons_per_line)
958     hacked_line_length = case mode of { ZigZagMode -> MAXINT; other -> line_length }
959
960 display mode IBOX(page_width) IBOX(ribbon_width) txt end doc
961   = case page_width MINUS ribbon_width of { gap_width ->
962     case gap_width DIV ILIT(2) of { shift ->
963     let
964         lay k (Nest k1 p)  = lay (k PLUS k1) p
965         lay k Empty        = end
966     
967         lay k (NilAbove p) = nl_text `txt` lay k p
968     
969         lay k (TextBeside s sl p)
970             = case mode of
971                     ZigZagMode |  k GREQ gap_width
972                                -> nl_text `txt` (
973                                   Str (multi_ch shift '/') `txt` (
974                                   nl_text `txt` (
975                                   lay1 (k MINUS shift) s sl p)))
976
977                                |  k LT ILIT(0)
978                                -> nl_text `txt` (
979                                   Str (multi_ch shift '\\') `txt` (
980                                   nl_text `txt` (
981                                   lay1 (k PLUS shift) s sl p )))
982
983                     other -> lay1 k s sl p
984     
985         lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k PLUS sl) p)
986     
987         lay2 k (NilAbove p)        = nl_text `txt` lay k p
988         lay2 k (TextBeside s sl p) = s `txt` (lay2 (k PLUS sl) p)
989         lay2 k (Nest _ p)          = lay2 k p
990         lay2 k Empty               = end
991     in
992     lay ILIT(0) doc
993     }}
994
995 cant_fail = error "easy_display: NoDoc"
996
997 indent n | n GREQ ILIT(8) = '\t' : indent (n MINUS ILIT(8))
998          | otherwise      = spaces n
999
1000 multi_ch n ch | n LTEQ ILIT(0) = ""
1001               | otherwise      = ch : multi_ch (n MINUS ILIT(1)) ch
1002
1003 spaces n | n LTEQ ILIT(0) = ""
1004          | otherwise      = ' ' : spaces (n MINUS ILIT(1))
1005 \end{code}
1006
1007 \begin{code}
1008 pprCols = (120 :: Int) -- could make configurable
1009
1010 printDoc :: Mode -> Handle -> Doc -> IO ()
1011 printDoc LeftMode hdl doc
1012   = do { printLeftRender hdl doc; hFlush hdl }
1013 printDoc mode hdl doc
1014   = do { fullRender mode pprCols 1.5 put done doc ;
1015          hFlush hdl }
1016   where
1017     put (Chr c)  next = hPutChar hdl c >> next 
1018     put (Str s)  next = hPutStr  hdl s >> next 
1019     put (PStr s) next = hPutFS   hdl s >> next 
1020     put (LStr s l) next = hPutLitString hdl s l >> next 
1021
1022     done = hPutChar hdl '\n'
1023
1024   -- some versions of hPutBuf will barf if the length is zero
1025 hPutLitString handle a# 0# = return ()
1026 hPutLitString handle a# l#
1027   = hPutBuf handle (Ptr a#) (I# l#)
1028
1029 -- Printing output in LeftMode is performance critical: it's used when
1030 -- dumping C and assembly output, so we allow ourselves a few dirty
1031 -- hacks:
1032 --
1033 --      (1) we specialise fullRender for LeftMode with IO output.
1034 --
1035 --      (2) we add a layer of buffering on top of Handles.  Handles
1036 --          don't perform well with lots of hPutChars, which is mostly
1037 --          what we're doing here, because Handles have to be thread-safe
1038 --          and async exception-safe.  We only have a single thread and don't
1039 --          care about exceptions, so we add a layer of fast buffering
1040 --          over the Handle interface.
1041 --
1042 --      (3) a few hacks in layLeft below to convince GHC to generate the right
1043 --          code.
1044
1045 printLeftRender :: Handle -> Doc -> IO ()
1046 printLeftRender hdl doc = do
1047   b <- newBufHandle hdl
1048   layLeft b (reduceDoc doc)
1049   bFlush b
1050
1051 -- HACK ALERT!  the "return () >>" below convinces GHC to eta-expand
1052 -- this function with the IO state lambda.  Otherwise we end up with
1053 -- closures in all the case branches.
1054 layLeft b _ | b `seq` False = undefined -- make it strict in b
1055 layLeft b NoDoc                 = cant_fail
1056 layLeft b (Union p q)           = return () >> layLeft b (first p q)
1057 layLeft b (Nest k p)            = return () >> layLeft b p
1058 layLeft b Empty                 = bPutChar b '\n'
1059 layLeft b (NilAbove p)          = bPutChar b '\n' >> layLeft b p
1060 layLeft b (TextBeside s sl p)   = put b s >> layLeft b p
1061  where
1062     put b _ | b `seq` False = undefined
1063     put b (Chr c)    = bPutChar b c
1064     put b (Str s)    = bPutStr  b s
1065     put b (PStr s)   = bPutFS   b s
1066     put b (LStr s l) = bPutLitString b s l
1067 \end{code}