f6a5a44e2ee7d5e5611582367d0b3e86771db449
[ghc.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 occasionally gave very weird 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 it 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, quote, 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 {-# LANGUAGE BangPatterns, CPP, MagicHash #-}
156
157 module Pretty (
158         Doc,            -- Abstract
159         Mode(..), TextDetails(..),
160
161         empty, isEmpty, nest,
162
163         char, text, ftext, ptext, ztext, zeroWidthText,
164         int, integer, float, double, rational,
165         parens, brackets, braces, quotes, quote, doubleQuotes,
166         semi, comma, colon, space, equals,
167         lparen, rparen, lbrack, rbrack, lbrace, rbrace, cparen,
168
169         (<>), (<+>), hcat, hsep,
170         ($$), ($+$), vcat,
171         sep, cat,
172         fsep, fcat,
173
174         hang, punctuate,
175
176         fullRender, printDoc, printDoc_, showDoc,
177         bufLeftRender -- performance hack
178   ) where
179
180 import BufWrite
181 import FastString
182 import FastTypes
183 import Panic
184 import Numeric (fromRat)
185 import System.IO
186
187 #if defined(__GLASGOW_HASKELL__)
188 --for a RULES
189 import GHC.Base ( unpackCString# )
190 import GHC.Exts ( Int# )
191 import GHC.Ptr  ( Ptr(..) )
192 #endif
193
194 -- Don't import Util( assertPanic ) because it makes a loop in the module structure
195
196 infixl 6 <>
197 infixl 6 <+>
198 infixl 5 $$, $+$
199 \end{code}
200
201
202 \begin{code}
203
204 -- Disable ASSERT checks; they are expensive!
205 #define LOCAL_ASSERT(x)
206
207 \end{code}
208
209
210 %*********************************************************
211 %*                                                       *
212 \subsection{The interface}
213 %*                                                       *
214 %*********************************************************
215
216 The primitive @Doc@ values
217
218 \begin{code}
219 empty                     :: Doc
220 isEmpty                   :: Doc    -> Bool
221 -- | Some text, but without any width. Use for non-printing text
222 -- such as a HTML or Latex tags
223 zeroWidthText :: String   -> Doc
224
225 text                      :: String -> Doc
226 char                      :: Char -> Doc
227
228 semi, comma, colon, space, equals              :: Doc
229 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
230
231 parens, brackets, braces    :: Doc -> Doc
232 quotes, quote, doubleQuotes :: Doc -> Doc
233
234 int      :: Int -> Doc
235 integer  :: Integer -> Doc
236 float    :: Float -> Doc
237 double   :: Double -> Doc
238 rational :: Rational -> Doc
239 \end{code}
240
241 Combining @Doc@ values
242
243 \begin{code}
244 (<>)   :: Doc -> Doc -> Doc     -- Beside
245 hcat   :: [Doc] -> Doc          -- List version of <>
246 (<+>)  :: Doc -> Doc -> Doc     -- Beside, separated by space
247 hsep   :: [Doc] -> Doc          -- List version of <+>
248
249 ($$)   :: Doc -> Doc -> Doc     -- Above; if there is no
250                                 -- overlap it "dovetails" the two
251 vcat   :: [Doc] -> Doc          -- List version of $$
252
253 cat    :: [Doc] -> Doc          -- Either hcat or vcat
254 sep    :: [Doc] -> Doc          -- Either hsep or vcat
255 fcat   :: [Doc] -> Doc          -- ``Paragraph fill'' version of cat
256 fsep   :: [Doc] -> Doc          -- ``Paragraph fill'' version of sep
257
258 nest   :: Int -> Doc -> Doc     -- Nested
259 \end{code}
260
261 GHC-specific ones.
262
263 \begin{code}
264 hang :: Doc -> Int -> Doc -> Doc
265 punctuate :: Doc -> [Doc] -> [Doc]      -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
266 \end{code}
267
268 Displaying @Doc@ values.
269
270 \begin{code}
271 instance Show Doc where
272   showsPrec _ doc cont = showDocPlus PageMode 100 doc cont
273
274 fullRender :: Mode
275            -> Int                       -- Line length
276            -> Float                     -- Ribbons per line
277            -> (TextDetails -> a -> a)   -- What to do with text
278            -> a                         -- What to do at the end
279            -> Doc
280            -> a                         -- Result
281
282 data Mode = PageMode            -- Normal
283           | ZigZagMode          -- With zig-zag cuts
284           | LeftMode            -- No indentation, infinitely long lines
285           | OneLineMode         -- All on one line
286 \end{code}
287
288
289 %*********************************************************
290 %*                                                       *
291 \subsection{The @Doc@ calculus}
292 %*                                                       *
293 %*********************************************************
294
295 The @Doc@ combinators satisfy the following laws:
296 \begin{verbatim}
297 Laws for $$
298 ~~~~~~~~~~~
299 <a1>    (x $$ y) $$ z   = x $$ (y $$ z)
300 <a2>    empty $$ x      = x
301 <a3>    x $$ empty      = x
302
303         ...ditto $+$...
304
305 Laws for <>
306 ~~~~~~~~~~~
307 <b1>    (x <> y) <> z   = x <> (y <> z)
308 <b2>    empty <> x      = empty
309 <b3>    x <> empty      = x
310
311         ...ditto <+>...
312
313 Laws for text
314 ~~~~~~~~~~~~~
315 <t1>    text s <> text t        = text (s++t)
316 <t2>    text "" <> x            = x, if x non-empty
317
318 Laws for nest
319 ~~~~~~~~~~~~~
320 <n1>    nest 0 x                = x
321 <n2>    nest k (nest k' x)      = nest (k+k') x
322 <n3>    nest k (x <> y)         = nest k z <> nest k y
323 <n4>    nest k (x $$ y)         = nest k x $$ nest k y
324 <n5>    nest k empty            = empty
325 <n6>    x <> nest k y           = x <> y, if x non-empty
326
327  - Note the side condition on <n6>!  It is this that
328    makes it OK for empty to be a left unit for <>.
329
330 Miscellaneous
331 ~~~~~~~~~~~~~
332 <m1>    (text s <> x) $$ y = text s <> ((text "" <> x)) $$
333                                          nest (-length s) y)
334
335 <m2>    (x $$ y) <> z = x $$ (y <> z)
336         if y non-empty
337
338
339 Laws for list versions
340 ~~~~~~~~~~~~~~~~~~~~~~
341 <l1>    sep (ps++[empty]++qs)   = sep (ps ++ qs)
342         ...ditto hsep, hcat, vcat, fill...
343
344 <l2>    nest k (sep ps) = sep (map (nest k) ps)
345         ...ditto hsep, hcat, vcat, fill...
346
347 Laws for oneLiner
348 ~~~~~~~~~~~~~~~~~
349 <o1>    oneLiner (nest k p) = nest k (oneLiner p)
350 <o2>    oneLiner (x <> y)   = oneLiner x <> oneLiner y
351 \end{verbatim}
352
353
354 You might think that the following verion of <m1> would
355 be neater:
356 \begin{verbatim}
357 <3 NO>  (text s <> x) $$ y = text s <> ((empty <> x)) $$
358                                          nest (-length s) y)
359 \end{verbatim}
360 But it doesn't work, for if x=empty, we would have
361 \begin{verbatim}
362         text s $$ y = text s <> (empty $$ nest (-length s) y)
363                     = text s <> nest (-length s) y
364 \end{verbatim}
365
366
367
368 %*********************************************************
369 %*                                                       *
370 \subsection{Simple derived definitions}
371 %*                                                       *
372 %*********************************************************
373
374 \begin{code}
375 semi  = char ';'
376 colon = char ':'
377 comma = char ','
378 space = char ' '
379 equals = char '='
380 lparen = char '('
381 rparen = char ')'
382 lbrack = char '['
383 rbrack = char ']'
384 lbrace = char '{'
385 rbrace = char '}'
386
387 int      n = text (show n)
388 integer  n = text (show n)
389 float    n = text (show n)
390 double   n = text (show n)
391 rational n = text (show (fromRat n :: Double))
392 --rational n = text (show (fromRationalX n)) -- _showRational 30 n)
393
394 quotes p        = char '`' <> p <> char '\''
395 quote p         = char '\'' <> p
396 doubleQuotes p  = char '"' <> p <> char '"'
397 parens p        = char '(' <> p <> char ')'
398 brackets p      = char '[' <> p <> char ']'
399 braces p        = char '{' <> p <> char '}'
400
401 cparen :: Bool -> Doc -> Doc
402 cparen True  = parens
403 cparen False = id
404
405 hcat = foldr (<>)  empty
406 hsep = foldr (<+>) empty
407 vcat = foldr ($$)  empty
408
409 hang d1 n d2 = sep [d1, nest n d2]
410
411 punctuate _ []     = []
412 punctuate p (d:ds) = go d ds
413                    where
414                      go d [] = [d]
415                      go d (e:es) = (d <> p) : go e es
416 \end{code}
417
418
419 %*********************************************************
420 %*                                                       *
421 \subsection{The @Doc@ data type}
422 %*                                                       *
423 %*********************************************************
424
425 A @Doc@ represents a {\em set} of layouts.  A @Doc@ with
426 no occurrences of @Union@ or @NoDoc@ represents just one layout.
427 \begin{code}
428 data Doc
429  = Empty                                -- empty
430  | NilAbove Doc                         -- text "" $$ x
431  | TextBeside !TextDetails FastInt Doc       -- text s <> x
432  | Nest FastInt Doc                         -- nest k x
433  | Union Doc Doc                        -- ul `union` ur
434  | NoDoc                                -- The empty set of documents
435  | Beside Doc Bool Doc                  -- True <=> space between
436  | Above  Doc Bool Doc                  -- True <=> never overlap
437
438 type RDoc = Doc         -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
439
440
441 reduceDoc :: Doc -> RDoc
442 reduceDoc (Beside p g q) = beside p g (reduceDoc q)
443 reduceDoc (Above  p g q) = above  p g (reduceDoc q)
444 reduceDoc p              = p
445
446
447 data TextDetails = Chr  {-#UNPACK#-}!Char
448                  | Str  String
449                  | PStr FastString                      -- a hashed string
450                  | ZStr FastZString                     -- a z-encoded string
451                  | LStr {-#UNPACK#-}!LitString FastInt  -- a '\0'-terminated
452                                                         -- array of bytes
453
454 space_text :: TextDetails
455 space_text = Chr ' '
456 nl_text :: TextDetails
457 nl_text    = Chr '\n'
458 \end{code}
459
460 Here are the invariants:
461 \begin{itemize}
462 \item
463 The argument of @NilAbove@ is never @Empty@. Therefore
464 a @NilAbove@ occupies at least two lines.
465
466 \item
467 The arugment of @TextBeside@ is never @Nest@.
468
469 \item
470 The layouts of the two arguments of @Union@ both flatten to the same string.
471
472 \item
473 The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
474
475 \item
476 The right argument of a union cannot be equivalent to the empty set (@NoDoc@).
477 If the left argument of a union is equivalent to the empty set (@NoDoc@),
478 then the @NoDoc@ appears in the first line.
479
480 \item
481 An empty document is always represented by @Empty@.
482 It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.
483
484 \item
485 The first line of every layout in the left argument of @Union@
486 is longer than the first line of any layout in the right argument.
487 (1) ensures that the left argument has a first line.  In view of (3),
488 this invariant means that the right argument must have at least two
489 lines.
490 \end{itemize}
491
492 \begin{code}
493 -- Arg of a NilAbove is always an RDoc
494 nilAbove_ :: Doc -> Doc
495 nilAbove_ p = LOCAL_ASSERT( _ok p ) NilAbove p
496             where
497               _ok Empty = False
498               _ok _     = True
499
500 -- Arg of a TextBeside is always an RDoc
501 textBeside_ :: TextDetails -> FastInt -> Doc -> Doc
502 textBeside_ s sl p = TextBeside s sl (LOCAL_ASSERT( _ok p ) p)
503                    where
504                      _ok (Nest _ _) = False
505                      _ok _          = True
506
507 -- Arg of Nest is always an RDoc
508 nest_ :: FastInt -> Doc -> Doc
509 nest_ k p = Nest k (LOCAL_ASSERT( _ok p ) p)
510           where
511             _ok Empty = False
512             _ok _     = True
513
514 -- Args of union are always RDocs
515 union_ :: Doc -> Doc -> Doc
516 union_ p q = Union (LOCAL_ASSERT( _ok p ) p) (LOCAL_ASSERT( _ok q ) q)
517            where
518              _ok (TextBeside _ _ _) = True
519              _ok (NilAbove _)       = True
520              _ok (Union _ _)        = True
521              _ok _                  = False
522 \end{code}
523
524 Notice the difference between
525         * NoDoc (no documents)
526         * Empty (one empty document; no height and no width)
527         * text "" (a document containing the empty string;
528                    one line high, but has no width)
529
530
531
532 %*********************************************************
533 %*                                                       *
534 \subsection{@empty@, @text@, @nest@, @union@}
535 %*                                                       *
536 %*********************************************************
537
538 \begin{code}
539 empty = Empty
540
541 isEmpty Empty = True
542 isEmpty _     = False
543
544 char  c = textBeside_ (Chr c) (_ILIT(1)) Empty
545
546 text  s = case iUnbox (length   s) of {sl -> textBeside_ (Str s)  sl Empty}
547 {-# NOINLINE [0] text #-}   -- Give the RULE a chance to fire
548                             -- It must wait till after phase 1 when
549                             -- the unpackCString first is manifested
550
551 ftext :: FastString -> Doc
552 ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty}
553 ptext :: LitString -> Doc
554 ptext s = case iUnbox (lengthLS s) of {sl -> textBeside_ (LStr s sl) sl Empty}
555 ztext :: FastZString -> Doc
556 ztext s = case iUnbox (lengthFZS s) of {sl -> textBeside_ (ZStr s) sl Empty}
557 zeroWidthText s = textBeside_ (Str s) (_ILIT(0)) Empty
558
559 #if defined(__GLASGOW_HASKELL__)
560 -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
561 -- intermediate packing/unpacking of the string.
562 {-# RULES
563   "text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
564  #-}
565 #endif
566
567 nest k  p = mkNest (iUnbox k) (reduceDoc p)        -- Externally callable version
568
569 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
570 mkNest :: Int# -> Doc -> Doc
571 mkNest k       (Nest k1 p) = mkNest (k +# k1) p
572 mkNest _       NoDoc       = NoDoc
573 mkNest _       Empty       = Empty
574 mkNest k       p  | k ==# _ILIT(0)  = p       -- Worth a try!
575 mkNest k       p           = nest_ k p
576
577 -- mkUnion checks for an empty document
578 mkUnion :: Doc -> Doc -> Doc
579 mkUnion Empty _ = Empty
580 mkUnion p q     = p `union_` q
581 \end{code}
582
583 %*********************************************************
584 %*                                                       *
585 \subsection{Vertical composition @$$@}
586 %*                                                       *
587 %*********************************************************
588
589
590 \begin{code}
591 p $$  q = Above p False q
592 ($+$) :: Doc -> Doc -> Doc
593 p $+$ q = Above p True q
594
595 above :: Doc -> Bool -> RDoc -> RDoc
596 above (Above p g1 q1)  g2 q2 = above p g1 (above q1 g2 q2)
597 above p@(Beside _ _ _) g  q  = aboveNest (reduceDoc p) g (_ILIT(0)) (reduceDoc q)
598 above p g q                  = aboveNest p             g (_ILIT(0)) (reduceDoc q)
599
600 aboveNest :: RDoc -> Bool -> FastInt -> RDoc -> RDoc
601 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
602
603 aboveNest NoDoc               _ _ _ = NoDoc
604 aboveNest (p1 `Union` p2)     g k q = aboveNest p1 g k q `union_`
605                                       aboveNest p2 g k q
606
607 aboveNest Empty               _ k q = mkNest k q
608 aboveNest (Nest k1 p)         g k q = nest_ k1 (aboveNest p g (k -# k1) q)
609                                   -- p can't be Empty, so no need for mkNest
610
611 aboveNest (NilAbove p)        g k q = nilAbove_ (aboveNest p g k q)
612 aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
613                                     where
614                                       !k1  = k -# sl
615                                       rest = case p of
616                                                 Empty -> nilAboveNest g k1 q
617                                                 _     -> aboveNest  p g k1 q
618 aboveNest _                   _ _ _ = panic "aboveNest: Unhandled case"
619 \end{code}
620
621 \begin{code}
622 nilAboveNest :: Bool -> FastInt -> RDoc -> RDoc
623 -- Specification: text s <> nilaboveNest g k q
624 --              = text s <> (text "" $g$ nest k q)
625
626 nilAboveNest _ _ Empty       = Empty    -- Here's why the "text s <>" is in the spec!
627 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k +# k1) q
628
629 nilAboveNest g k q           | (not g) && (k ># _ILIT(0))        -- No newline if no overlap
630                              = textBeside_ (Str (spaces k)) k q
631                              | otherwise                        -- Put them really above
632                              = nilAbove_ (mkNest k q)
633 \end{code}
634
635
636 %*********************************************************
637 %*                                                       *
638 \subsection{Horizontal composition @<>@}
639 %*                                                       *
640 %*********************************************************
641
642 \begin{code}
643 p <>  q = Beside p False q
644 p <+> q = Beside p True  q
645
646 beside :: Doc -> Bool -> RDoc -> RDoc
647 -- Specification: beside g p q = p <g> q
648
649 beside NoDoc               _ _   = NoDoc
650 beside (p1 `Union` p2)     g q   = (beside p1 g q) `union_` (beside p2 g q)
651 beside Empty               _ q   = q
652 beside (Nest k p)          g q   = nest_ k $! beside p g q       -- p non-empty
653 beside p@(Beside p1 g1 q1) g2 q2
654            {- (A `op1` B) `op2` C == A `op1` (B `op2` C)  iff op1 == op2
655                                                  [ && (op1 == <> || op1 == <+>) ] -}
656          | g1 == g2              = beside p1 g1 $! beside q1 g2 q2
657          | otherwise             = beside (reduceDoc p) g2 q2
658 beside p@(Above _ _ _)     g q   = let d = reduceDoc p in d `seq` beside d g q
659 beside (NilAbove p)        g q   = nilAbove_ $! beside p g q
660 beside (TextBeside s sl p) g q   = textBeside_ s sl $! rest
661                                where
662                                   rest = case p of
663                                            Empty -> nilBeside g q
664                                            _     -> beside p g q
665 \end{code}
666
667 \begin{code}
668 nilBeside :: Bool -> RDoc -> RDoc
669 -- Specification: text "" <> nilBeside g p
670 --              = text "" <g> p
671
672 nilBeside _ Empty      = Empty  -- Hence the text "" in the spec
673 nilBeside g (Nest _ p) = nilBeside g p
674 nilBeside g p          | g         = textBeside_ space_text (_ILIT(1)) p
675                        | otherwise = p
676 \end{code}
677
678 %*********************************************************
679 %*                                                       *
680 \subsection{Separate, @sep@, Hughes version}
681 %*                                                       *
682 %*********************************************************
683
684 \begin{code}
685 -- Specification: sep ps  = oneLiner (hsep ps)
686 --                         `union`
687 --                          vcat ps
688
689 sep = sepX True         -- Separate with spaces
690 cat = sepX False        -- Don't
691
692 sepX :: Bool -> [Doc] -> Doc
693 sepX _ []     = empty
694 sepX x (p:ps) = sep1 x (reduceDoc p) (_ILIT(0)) ps
695
696
697 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
698 --                            = oneLiner (x <g> nest k (hsep ys))
699 --                              `union` x $$ nest k (vcat ys)
700
701 sep1 :: Bool -> RDoc -> FastInt -> [Doc] -> RDoc
702 sep1 _ NoDoc               _ _  = NoDoc
703 sep1 g (p `Union` q)       k ys = sep1 g p k ys
704                                   `union_`
705                                   (aboveNest q False k (reduceDoc (vcat ys)))
706
707 sep1 g Empty               k ys = mkNest k (sepX g ys)
708 sep1 g (Nest n p)          k ys = nest_ n (sep1 g p (k -# n) ys)
709
710 sep1 _ (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
711 sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k -# sl) ys)
712 sep1 _ _                   _ _  = panic "sep1: Unhandled case"
713
714 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
715 -- Called when we have already found some text in the first item
716 -- We have to eat up nests
717
718 sepNB :: Bool -> Doc -> FastInt -> [Doc] -> Doc
719 sepNB g (Nest _ p)  k ys  = sepNB g p k ys
720
721 sepNB g Empty k ys        = oneLiner (nilBeside g (reduceDoc rest))
722                                 `mkUnion`
723                             nilAboveNest False k (reduceDoc (vcat ys))
724                           where
725                             rest | g         = hsep ys
726                                  | otherwise = hcat ys
727
728 sepNB g p k ys            = sep1 g p k ys
729 \end{code}
730
731 %*********************************************************
732 %*                                                       *
733 \subsection{@fill@}
734 %*                                                       *
735 %*********************************************************
736
737 \begin{code}
738 fsep = fill True
739 fcat = fill False
740
741 -- Specification:
742 --   fill []  = empty
743 --   fill [p] = p
744 --   fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
745 --                                          (fill (oneLiner p2 : ps))
746 --                     `union`
747 --                      p1 $$ fill ps
748
749 fill :: Bool -> [Doc] -> Doc
750 fill _ []     = empty
751 fill g (p:ps) = fill1 g (reduceDoc p) (_ILIT(0)) ps
752
753
754 fill1 :: Bool -> RDoc -> FastInt -> [Doc] -> Doc
755 fill1 _ NoDoc               _ _  = NoDoc
756 fill1 g (p `Union` q)       k ys = fill1 g p k ys
757                                    `union_`
758                                    (aboveNest q False k (fill g ys))
759
760 fill1 g Empty               k ys = mkNest k (fill g ys)
761 fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k -# n) ys)
762
763 fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fill g ys))
764 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k -# sl) ys)
765 fill1 _ _                   _ _  = panic "fill1: Unhandled case"
766
767 fillNB :: Bool -> Doc -> Int# -> [Doc] -> Doc
768 fillNB g (Nest _ p)  k ys  = fillNB g p k ys
769 fillNB _ Empty _ []        = Empty
770 fillNB g Empty k (y:ys)    = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
771                              `mkUnion`
772                              nilAboveNest False k (fill g (y:ys))
773                            where
774                              !k1 | g         = k -# _ILIT(1)
775                                  | otherwise = k
776
777 fillNB g p k ys            = fill1 g p k ys
778 \end{code}
779
780
781 %*********************************************************
782 %*                                                       *
783 \subsection{Selecting the best layout}
784 %*                                                       *
785 %*********************************************************
786
787 \begin{code}
788 best :: Int             -- Line length
789      -> Int             -- Ribbon length
790      -> RDoc
791      -> RDoc            -- No unions in here!
792
793 best w_ r_ p
794   = get (iUnbox w_) p
795   where
796     !r = iUnbox r_
797     get :: FastInt          -- (Remaining) width of line
798         -> Doc -> Doc
799     get _ Empty               = Empty
800     get _ NoDoc               = NoDoc
801     get w (NilAbove p)        = nilAbove_ (get w p)
802     get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
803     get w (Nest k p)          = nest_ k (get (w -# k) p)
804     get w (p `Union` q)       = nicest w r (get w p) (get w q)
805     get _ _                   = panic "best/get: Unhandled case"
806
807     get1 :: FastInt         -- (Remaining) width of line
808          -> FastInt         -- Amount of first line already eaten up
809          -> Doc         -- This is an argument to TextBeside => eat Nests
810          -> Doc         -- No unions in here!
811
812     get1 _ _  Empty               = Empty
813     get1 _ _  NoDoc               = NoDoc
814     get1 w sl (NilAbove p)        = nilAbove_ (get (w -# sl) p)
815     get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl +# tl) p)
816     get1 w sl (Nest _ p)          = get1 w sl p
817     get1 w sl (p `Union` q)       = nicest1 w r sl (get1 w sl p)
818                                                    (get1 w sl q)
819     get1 _ _  _                   = panic "best/get1: Unhandled case"
820
821 nicest :: FastInt -> FastInt -> Doc -> Doc -> Doc
822 nicest w r p q = nicest1 w r (_ILIT(0)) p q
823 nicest1 :: FastInt -> FastInt -> Int# -> Doc -> Doc -> Doc
824 nicest1 w r sl p q | fits ((w `minFastInt` r) -# sl) p = p
825                    | otherwise                   = q
826
827 fits :: FastInt     -- Space available
828      -> Doc
829      -> Bool    -- True if *first line* of Doc fits in space available
830
831 fits n _   | n <# _ILIT(0) = False
832 fits _ NoDoc               = False
833 fits _ Empty               = True
834 fits _ (NilAbove _)        = True
835 fits n (TextBeside _ sl p) = fits (n -# sl) p
836 fits _ _                   = panic "fits: Unhandled case"
837 \end{code}
838
839 @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
840 @first@ returns its first argument if it is non-empty, otherwise its second.
841
842 \begin{code}
843 first :: Doc -> Doc -> Doc
844 first p q | nonEmptySet p = p
845           | otherwise     = q
846
847 nonEmptySet :: Doc -> Bool
848 nonEmptySet NoDoc              = False
849 nonEmptySet (_ `Union` _)      = True
850 nonEmptySet Empty              = True
851 nonEmptySet (NilAbove _)       = True           -- NoDoc always in first line
852 nonEmptySet (TextBeside _ _ p) = nonEmptySet p
853 nonEmptySet (Nest _ p)         = nonEmptySet p
854 nonEmptySet _                  = panic "nonEmptySet: Unhandled case"
855 \end{code}
856
857 @oneLiner@ returns the one-line members of the given set of @Doc@s.
858
859 \begin{code}
860 oneLiner :: Doc -> Doc
861 oneLiner NoDoc               = NoDoc
862 oneLiner Empty               = Empty
863 oneLiner (NilAbove _)        = NoDoc
864 oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
865 oneLiner (Nest k p)          = nest_ k (oneLiner p)
866 oneLiner (p `Union` _)       = oneLiner p
867 oneLiner _                   = panic "oneLiner: Unhandled case"
868 \end{code}
869
870
871
872 %*********************************************************
873 %*                                                       *
874 \subsection{Displaying the best layout}
875 %*                                                       *
876 %*********************************************************
877
878
879 \begin{code}
880 showDocPlus :: Mode -> Int -> Doc -> String -> String
881 showDocPlus mode cols doc rest = fullRender mode cols 1.5 string_txt rest doc
882
883 showDoc :: Mode -> Int -> Doc -> String
884 showDoc mode cols doc = showDocPlus mode cols doc ""
885
886 string_txt :: TextDetails -> String -> String
887 string_txt (Chr c)   s  = c:s
888 string_txt (Str s1)  s2 = s1 ++ s2
889 string_txt (PStr s1) s2 = unpackFS s1 ++ s2
890 string_txt (ZStr s1) s2 = zString s1 ++ s2
891 string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
892 \end{code}
893
894 \begin{code}
895
896 fullRender OneLineMode _ _ txt end doc
897   = lay (reduceDoc doc)
898   where
899     lay NoDoc              = cant_fail
900     lay (Union _ q)        = lay q -- Second arg can't be NoDoc
901     lay (Nest _ p)         = lay p
902     lay Empty              = end
903     lay (NilAbove p)       = space_text `txt` lay p -- NoDoc always on
904                                                     -- first line
905     lay (TextBeside s _ p) = s `txt` lay p
906     lay _                  = panic "fullRender/OneLineMode/lay: Unhandled case"
907
908 fullRender LeftMode    _ _ txt end doc
909   = lay (reduceDoc doc)
910   where
911     lay NoDoc              = cant_fail
912     lay (Union p q)        = lay (first p q)
913     lay (Nest _ p)         = lay p
914     lay Empty              = end
915     lay (NilAbove p)       = nl_text `txt` lay p -- NoDoc always on first line
916     lay (TextBeside s _ p) = s `txt` lay p
917     lay _                  = panic "fullRender/LeftMode/lay: Unhandled case"
918
919 fullRender mode line_length ribbons_per_line txt end doc
920   = display mode line_length ribbon_length txt end best_doc
921   where
922     best_doc = best hacked_line_length ribbon_length (reduceDoc doc)
923
924     hacked_line_length, ribbon_length :: Int
925     ribbon_length = round (fromIntegral line_length / ribbons_per_line)
926     hacked_line_length = case mode of
927                          ZigZagMode -> maxBound
928                          _ -> line_length
929
930 display :: Mode -> Int -> Int -> (TextDetails -> t -> t) -> t -> Doc -> t
931 display mode page_width ribbon_width txt end doc
932   = case (iUnbox page_width) -# (iUnbox ribbon_width) of { gap_width ->
933     case gap_width `quotFastInt` _ILIT(2) of { shift ->
934     let
935         lay k (Nest k1 p)  = lay (k +# k1) p
936         lay _ Empty        = end
937
938         lay k (NilAbove p) = nl_text `txt` lay k p
939
940         lay k (TextBeside s sl p)
941             = case mode of
942                     ZigZagMode |  k >=# gap_width
943                                -> nl_text `txt` (
944                                   Str (multi_ch shift '/') `txt` (
945                                   nl_text `txt` (
946                                   lay1 (k -# shift) s sl p)))
947
948                                |  k <# _ILIT(0)
949                                -> nl_text `txt` (
950                                   Str (multi_ch shift '\\') `txt` (
951                                   nl_text `txt` (
952                                   lay1 (k +# shift) s sl p )))
953
954                     _ -> lay1 k s sl p
955         lay _ _            = panic "display/lay: Unhandled case"
956
957         lay1 k s sl p = indent k (s `txt` lay2 (k +# sl) p)
958
959         lay2 k (NilAbove p)        = nl_text `txt` lay k p
960         lay2 k (TextBeside s sl p) = s `txt` (lay2 (k +# sl) p)
961         lay2 k (Nest _ p)          = lay2 k p
962         lay2 _ Empty               = end
963         lay2 _ _                   = panic "display/lay2: Unhandled case"
964
965         -- optimise long indentations using LitString chunks of 8 spaces
966         indent n r | n >=# _ILIT(8) = LStr (sLit "        ") (_ILIT(8)) `txt`
967                                       indent (n -# _ILIT(8)) r
968                    | otherwise      = Str (spaces n) `txt` r
969     in
970     lay (_ILIT(0)) doc
971     }}
972
973 cant_fail :: a
974 cant_fail = error "easy_display: NoDoc"
975
976 multi_ch :: Int# -> Char -> String
977 multi_ch n ch | n <=# _ILIT(0) = ""
978               | otherwise      = ch : multi_ch (n -# _ILIT(1)) ch
979
980 spaces :: Int# -> String
981 spaces n | n <=# _ILIT(0) = ""
982          | otherwise      = ' ' : spaces (n -# _ILIT(1))
983
984 \end{code}
985
986 \begin{code}
987 printDoc :: Mode -> Int -> Handle -> Doc -> IO ()
988 -- printDoc adds a newline to the end
989 printDoc mode cols hdl doc = printDoc_ mode cols hdl (doc $$ text "")
990
991 printDoc_ :: Mode -> Int -> Handle -> Doc -> IO ()
992 -- printDoc_ does not add a newline at the end, so that
993 -- successive calls can output stuff on the same line
994 -- Rather like putStr vs putStrLn
995 printDoc_ LeftMode _ hdl doc
996   = do { printLeftRender hdl doc; hFlush hdl }
997 printDoc_ mode pprCols hdl doc
998   = do { fullRender mode pprCols 1.5 put done doc ;
999          hFlush hdl }
1000   where
1001     put (Chr c)  next = hPutChar hdl c >> next
1002     put (Str s)  next = hPutStr  hdl s >> next
1003     put (PStr s) next = hPutStr  hdl (unpackFS s) >> next
1004                         -- NB. not hPutFS, we want this to go through
1005                         -- the I/O library's encoding layer. (#3398)
1006     put (ZStr s) next = hPutFZS  hdl s >> next
1007     put (LStr s l) next = hPutLitString hdl s l >> next
1008
1009     done = return () -- hPutChar hdl '\n'
1010
1011   -- some versions of hPutBuf will barf if the length is zero
1012 hPutLitString :: Handle -> Ptr a -> Int# -> IO ()
1013 hPutLitString handle a l = if l ==# _ILIT(0)
1014                             then return ()
1015                             else hPutBuf handle a (iBox l)
1016
1017 -- Printing output in LeftMode is performance critical: it's used when
1018 -- dumping C and assembly output, so we allow ourselves a few dirty
1019 -- hacks:
1020 --
1021 -- (1) we specialise fullRender for LeftMode with IO output.
1022 --
1023 -- (2) we add a layer of buffering on top of Handles.  Handles
1024 --     don't perform well with lots of hPutChars, which is mostly
1025 --     what we're doing here, because Handles have to be thread-safe
1026 --     and async exception-safe.  We only have a single thread and don't
1027 --     care about exceptions, so we add a layer of fast buffering
1028 --     over the Handle interface.
1029 --
1030 -- (3) a few hacks in layLeft below to convince GHC to generate the right
1031 --     code.
1032
1033 printLeftRender :: Handle -> Doc -> IO ()
1034 printLeftRender hdl doc = do
1035   b <- newBufHandle hdl
1036   bufLeftRender b doc
1037   bFlush b
1038
1039 bufLeftRender :: BufHandle -> Doc -> IO ()
1040 bufLeftRender b doc = layLeft b (reduceDoc doc)
1041
1042 -- HACK ALERT!  the "return () >>" below convinces GHC to eta-expand
1043 -- this function with the IO state lambda.  Otherwise we end up with
1044 -- closures in all the case branches.
1045 layLeft :: BufHandle -> Doc -> IO ()
1046 layLeft b _ | b `seq` False  = undefined -- make it strict in b
1047 layLeft _ NoDoc              = cant_fail
1048 layLeft b (Union p q)        = return () >> layLeft b (first p q)
1049 layLeft b (Nest _ p)         = return () >> layLeft b p
1050 layLeft b Empty              = bPutChar b '\n'
1051 layLeft b (NilAbove p)       = bPutChar b '\n' >> layLeft b p
1052 layLeft b (TextBeside s _ p) = put b s >> layLeft b p
1053  where
1054     put b _ | b `seq` False = undefined
1055     put b (Chr c)    = bPutChar b c
1056     put b (Str s)    = bPutStr  b s
1057     put b (PStr s)   = bPutFS   b s
1058     put b (ZStr s)   = bPutFZS  b s
1059     put b (LStr s l) = bPutLitString b s l
1060 layLeft _ _                  = panic "layLeft: Unhandled case"
1061 \end{code}