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