added sizedText
[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
177 -- ** Converting values into documents
178 char, text, ptext, sizedText, zeroWidthText,
179 int, integer, float, double, rational,
180
181 -- ** Simple derived documents
182 semi, comma, colon, space, equals,
183 lparen, rparen, lbrack, rbrack, lbrace, rbrace,
184
185 -- ** Wrapping documents in delimiters
186 parens, brackets, braces, quotes, doubleQuotes,
187
188 -- ** Combining documents
189 empty,
190 (<>), (<+>), hcat, hsep,
191 ($$), ($+$), vcat,
192 sep, cat,
193 fsep, fcat,
194 nest,
195 hang, punctuate,
196
197 -- * Predicates on documents
198 isEmpty,
199
200 -- * Rendering documents
201
202 -- ** Default rendering
203 render,
204
205 -- ** Rendering with a particular style
206 Style(..),
207 style,
208 renderStyle,
209
210 -- ** General rendering
211 fullRender,
212 Mode(..), TextDetails(..),
213
214 ) where
215
216
217 import Prelude
218 import Data.Monoid ( Monoid(mempty, mappend) )
219 import Data.String ( IsString(fromString) )
220
221 infixl 6 <>
222 infixl 6 <+>
223 infixl 5 $$, $+$
224
225 -- ---------------------------------------------------------------------------
226 -- The interface
227
228 -- The primitive Doc values
229
230 isEmpty :: Doc -> Bool; -- ^ Returns 'True' if the document is empty
231
232 -- | The empty document, with no height and no width.
233 -- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere
234 -- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc.
235 empty :: Doc
236
237 semi :: Doc; -- ^ A ';' character
238 comma :: Doc; -- ^ A ',' character
239 colon :: Doc; -- ^ A ':' character
240 space :: Doc; -- ^ A space character
241 equals :: Doc; -- ^ A '=' character
242 lparen :: Doc; -- ^ A '(' character
243 rparen :: Doc; -- ^ A ')' character
244 lbrack :: Doc; -- ^ A '[' character
245 rbrack :: Doc; -- ^ A ']' character
246 lbrace :: Doc; -- ^ A '{' character
247 rbrace :: Doc; -- ^ A '}' character
248
249 -- | A document of height and width 1, containing a literal character.
250 char :: Char -> Doc
251
252 -- | A document of height 1 containing a literal string.
253 -- 'text' satisfies the following laws:
254 --
255 -- * @'text' s '<>' 'text' t = 'text' (s'++'t)@
256 --
257 -- * @'text' \"\" '<>' x = x@, if @x@ non-empty
258 --
259 -- The side condition on the last law is necessary because @'text' \"\"@
260 -- has height 1, while 'empty' has no height.
261 text :: String -> Doc
262
263 instance IsString Doc where
264 fromString = text
265
266 -- | An obsolete function, now identical to 'text'.
267 ptext :: String -> Doc
268
269 -- | Some text with any width. (@text s = sizedText (length s) s@)
270 sizedText :: Int -> String -> Doc
271
272 -- | Some text, but without any width. Use for non-printing text
273 -- such as a HTML or Latex tags
274 zeroWidthText :: String -> Doc
275
276 int :: Int -> Doc; -- ^ @int n = text (show n)@
277 integer :: Integer -> Doc; -- ^ @integer n = text (show n)@
278 float :: Float -> Doc; -- ^ @float n = text (show n)@
279 double :: Double -> Doc; -- ^ @double n = text (show n)@
280 rational :: Rational -> Doc; -- ^ @rational n = text (show n)@
281
282 parens :: Doc -> Doc; -- ^ Wrap document in @(...)@
283 brackets :: Doc -> Doc; -- ^ Wrap document in @[...]@
284 braces :: Doc -> Doc; -- ^ Wrap document in @{...}@
285 quotes :: Doc -> Doc; -- ^ Wrap document in @\'...\'@
286 doubleQuotes :: Doc -> Doc; -- ^ Wrap document in @\"...\"@
287
288 -- Combining @Doc@ values
289
290 instance Monoid Doc where
291 mempty = empty
292 mappend = (<>)
293
294 -- | Beside.
295 -- '<>' is associative, with identity 'empty'.
296 (<>) :: Doc -> Doc -> Doc
297
298 -- | Beside, separated by space, unless one of the arguments is 'empty'.
299 -- '<+>' is associative, with identity 'empty'.
300 (<+>) :: Doc -> Doc -> Doc
301
302 -- | Above, except that if the last line of the first argument stops
303 -- at least one position before the first line of the second begins,
304 -- these two lines are overlapped. For example:
305 --
306 -- > text "hi" $$ nest 5 (text "there")
307 --
308 -- lays out as
309 --
310 -- > hi there
311 --
312 -- rather than
313 --
314 -- > hi
315 -- > there
316 --
317 -- '$$' is associative, with identity 'empty', and also satisfies
318 --
319 -- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty.
320 --
321 ($$) :: Doc -> Doc -> Doc
322
323 -- | Above, with no overlapping.
324 -- '$+$' is associative, with identity 'empty'.
325 ($+$) :: Doc -> Doc -> Doc
326
327 hcat :: [Doc] -> Doc; -- ^List version of '<>'.
328 hsep :: [Doc] -> Doc; -- ^List version of '<+>'.
329 vcat :: [Doc] -> Doc; -- ^List version of '$$'.
330
331 cat :: [Doc] -> Doc; -- ^ Either 'hcat' or 'vcat'.
332 sep :: [Doc] -> Doc; -- ^ Either 'hsep' or 'vcat'.
333 fcat :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of 'cat'.
334 fsep :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of 'sep'.
335
336 -- | Nest (or indent) a document by a given number of positions
337 -- (which may also be negative). 'nest' satisfies the laws:
338 --
339 -- * @'nest' 0 x = x@
340 --
341 -- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@
342 --
343 -- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@
344 --
345 -- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@
346 --
347 -- * @'nest' k 'empty' = 'empty'@
348 --
349 -- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty
350 --
351 -- The side condition on the last law is needed because
352 -- 'empty' is a left identity for '<>'.
353 nest :: Int -> Doc -> Doc
354
355 -- GHC-specific ones.
356
357 -- | @hang d1 n d2 = sep [d1, nest n d2]@
358 hang :: Doc -> Int -> Doc -> Doc
359
360 -- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@
361 punctuate :: Doc -> [Doc] -> [Doc]
362
363
364 -- Displaying @Doc@ values.
365
366 instance Show Doc where
367 showsPrec _ doc cont = showDoc doc cont
368
369 -- | Renders the document as a string using the default 'style'.
370 render :: Doc -> String
371
372 -- | The general rendering interface.
373 fullRender :: Mode -- ^Rendering mode
374 -> Int -- ^Line length
375 -> Float -- ^Ribbons per line
376 -> (TextDetails -> a -> a) -- ^What to do with text
377 -> a -- ^What to do at the end
378 -> Doc -- ^The document
379 -> a -- ^Result
380
381 -- | Render the document as a string using a specified style.
382 renderStyle :: Style -> Doc -> String
383
384 -- | A rendering style.
385 data Style
386 = Style { mode :: Mode -- ^ The rendering mode
387 , lineLength :: Int -- ^ Length of line, in chars
388 , ribbonsPerLine :: Float -- ^ Ratio of ribbon length to line length
389 }
390
391 -- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@).
392 style :: Style
393 style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode }
394
395 -- | Rendering mode.
396 data Mode = PageMode -- ^Normal
397 | ZigZagMode -- ^With zig-zag cuts
398 | LeftMode -- ^No indentation, infinitely long lines
399 | OneLineMode -- ^All on one line
400
401 -- ---------------------------------------------------------------------------
402 -- The Doc calculus
403
404 -- The Doc combinators satisfy the following laws:
405
406 {-
407 Laws for $$
408 ~~~~~~~~~~~
409 <a1> (x $$ y) $$ z = x $$ (y $$ z)
410 <a2> empty $$ x = x
411 <a3> x $$ empty = x
412
413 ...ditto $+$...
414
415 Laws for <>
416 ~~~~~~~~~~~
417 <b1> (x <> y) <> z = x <> (y <> z)
418 <b2> empty <> x = empty
419 <b3> x <> empty = x
420
421 ...ditto <+>...
422
423 Laws for text
424 ~~~~~~~~~~~~~
425 <t1> text s <> text t = text (s++t)
426 <t2> text "" <> x = x, if x non-empty
427
428 ** because of law n6, t2 only holds if x doesn't
429 ** start with `nest'.
430
431
432 Laws for nest
433 ~~~~~~~~~~~~~
434 <n1> nest 0 x = x
435 <n2> nest k (nest k' x) = nest (k+k') x
436 <n3> nest k (x <> y) = nest k x <> nest k y
437 <n4> nest k (x $$ y) = nest k x $$ nest k y
438 <n5> nest k empty = empty
439 <n6> x <> nest k y = x <> y, if x non-empty
440
441 ** Note the side condition on <n6>! It is this that
442 ** makes it OK for empty to be a left unit for <>.
443
444 Miscellaneous
445 ~~~~~~~~~~~~~
446 <m1> (text s <> x) $$ y = text s <> ((text "" <> x) $$
447 nest (-length s) y)
448
449 <m2> (x $$ y) <> z = x $$ (y <> z)
450 if y non-empty
451
452
453 Laws for list versions
454 ~~~~~~~~~~~~~~~~~~~~~~
455 <l1> sep (ps++[empty]++qs) = sep (ps ++ qs)
456 ...ditto hsep, hcat, vcat, fill...
457
458 <l2> nest k (sep ps) = sep (map (nest k) ps)
459 ...ditto hsep, hcat, vcat, fill...
460
461 Laws for oneLiner
462 ~~~~~~~~~~~~~~~~~
463 <o1> oneLiner (nest k p) = nest k (oneLiner p)
464 <o2> oneLiner (x <> y) = oneLiner x <> oneLiner y
465
466 You might think that the following verion of <m1> would
467 be neater:
468
469 <3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$
470 nest (-length s) y)
471
472 But it doesn't work, for if x=empty, we would have
473
474 text s $$ y = text s <> (empty $$ nest (-length s) y)
475 = text s <> nest (-length s) y
476 -}
477
478 -- ---------------------------------------------------------------------------
479 -- Simple derived definitions
480
481 semi = char ';'
482 colon = char ':'
483 comma = char ','
484 space = char ' '
485 equals = char '='
486 lparen = char '('
487 rparen = char ')'
488 lbrack = char '['
489 rbrack = char ']'
490 lbrace = char '{'
491 rbrace = char '}'
492
493 int n = text (show n)
494 integer n = text (show n)
495 float n = text (show n)
496 double n = text (show n)
497 rational n = text (show n)
498 -- SIGBJORN wrote instead:
499 -- rational n = text (show (fromRationalX n))
500
501 quotes p = char '\'' <> p <> char '\''
502 doubleQuotes p = char '"' <> p <> char '"'
503 parens p = char '(' <> p <> char ')'
504 brackets p = char '[' <> p <> char ']'
505 braces p = char '{' <> p <> char '}'
506
507 -- lazy list versions
508 hcat = reduceAB . foldr (beside_' False) empty
509 hsep = reduceAB . foldr (beside_' True) empty
510 vcat = reduceAB . foldr (above_' False) empty
511
512 beside_' :: Bool -> Doc -> Doc -> Doc
513 beside_' _ p Empty = p
514 beside_' g p q = Beside p g q
515
516 above_' :: Bool -> Doc -> Doc -> Doc
517 above_' _ p Empty = p
518 above_' g p q = Above p g q
519
520 reduceAB :: Doc -> Doc
521 reduceAB (Above Empty _ q) = q
522 reduceAB (Beside Empty _ q) = q
523 reduceAB doc = doc
524
525 hang d1 n d2 = sep [d1, nest n d2]
526
527 punctuate _ [] = []
528 punctuate p (d:ds) = go d ds
529 where
530 go d' [] = [d']
531 go d' (e:es) = (d' <> p) : go e es
532
533 -- ---------------------------------------------------------------------------
534 -- The Doc data type
535
536 -- A Doc represents a *set* of layouts. A Doc with
537 -- no occurrences of Union or NoDoc represents just one layout.
538
539 -- | The abstract type of documents.
540 -- The 'Show' instance is equivalent to using 'render'.
541 data Doc
542 = Empty -- empty
543 | NilAbove Doc -- text "" $$ x
544 | TextBeside TextDetails !Int Doc -- text s <> x
545 | Nest !Int Doc -- nest k x
546 | Union Doc Doc -- ul `union` ur
547 | NoDoc -- The empty set of documents
548 | Beside Doc Bool Doc -- True <=> space between
549 | Above Doc Bool Doc -- True <=> never overlap
550
551 type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
552
553
554 reduceDoc :: Doc -> RDoc
555 reduceDoc (Beside p g q) = beside p g (reduceDoc q)
556 reduceDoc (Above p g q) = above p g (reduceDoc q)
557 reduceDoc p = p
558
559
560 data TextDetails = Chr Char
561 | Str String
562 | PStr String
563 space_text, nl_text :: TextDetails
564 space_text = Chr ' '
565 nl_text = Chr '\n'
566
567 {-
568 Here are the invariants:
569
570 1) The argument of NilAbove is never Empty. Therefore
571 a NilAbove occupies at least two lines.
572
573 2) The argument of @TextBeside@ is never @Nest@.
574
575
576 3) The layouts of the two arguments of @Union@ both flatten to the same
577 string.
578
579 4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
580
581 5) A @NoDoc@ may only appear on the first line of the left argument of an
582 union. Therefore, the right argument of an union can never be equivalent
583 to the empty set (@NoDoc@).
584
585 6) An empty document is always represented by @Empty@. It can't be
586 hidden inside a @Nest@, or a @Union@ of two @Empty@s.
587
588 7) The first line of every layout in the left argument of @Union@ is
589 longer than the first line of any layout in the right argument.
590 (1) ensures that the left argument has a first line. In view of
591 (3), this invariant means that the right argument must have at
592 least two lines.
593 -}
594
595 -- Invariant: Args to the 4 functions below are always RDocs
596 nilAbove_ :: RDoc -> RDoc
597 nilAbove_ p = NilAbove p
598
599 -- Arg of a TextBeside is always an RDoc
600 textBeside_ :: TextDetails -> Int -> RDoc -> RDoc
601 textBeside_ s sl p = TextBeside s sl p
602
603 nest_ :: Int -> RDoc -> RDoc
604 nest_ k p = Nest k p
605
606 union_ :: RDoc -> RDoc -> RDoc
607 union_ p q = Union p q
608
609
610 -- Notice the difference between
611 -- * NoDoc (no documents)
612 -- * Empty (one empty document; no height and no width)
613 -- * text "" (a document containing the empty string;
614 -- one line high, but has no width)
615
616
617 -- ---------------------------------------------------------------------------
618 -- @empty@, @text@, @nest@, @union@
619
620 empty = Empty
621
622 isEmpty Empty = True
623 isEmpty _ = False
624
625 char c = textBeside_ (Chr c) 1 Empty
626 text s = case length s of {sl -> textBeside_ (Str s) sl Empty}
627 ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty}
628 sizedText l s = textBeside_ (Str s) l Empty
629 zeroWidthText = sizedText 0
630
631 nest k p = mkNest k (reduceDoc p) -- Externally callable version
632
633 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
634 mkNest :: Int -> Doc -> Doc
635 mkNest k _ | k `seq` False = undefined
636 mkNest k (Nest k1 p) = mkNest (k + k1) p
637 mkNest _ NoDoc = NoDoc
638 mkNest _ Empty = Empty
639 mkNest 0 p = p -- Worth a try!
640 mkNest k p = nest_ k p
641
642 -- mkUnion checks for an empty document
643 mkUnion :: Doc -> Doc -> Doc
644 mkUnion Empty _ = Empty
645 mkUnion p q = p `union_` q
646
647 -- ---------------------------------------------------------------------------
648 -- Vertical composition @$$@
649
650 above_ :: Doc -> Bool -> Doc -> Doc
651 above_ p _ Empty = p
652 above_ Empty _ q = q
653 above_ p g q = Above p g q
654
655 p $$ q = above_ p False q
656 p $+$ q = above_ p True q
657
658 above :: Doc -> Bool -> RDoc -> RDoc
659 above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
660 above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q)
661 above p g q = aboveNest p g 0 (reduceDoc q)
662
663 aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
664 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
665
666 aboveNest _ _ k _ | k `seq` False = undefined
667 aboveNest NoDoc _ _ _ = NoDoc
668 aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
669 aboveNest p2 g k q
670
671 aboveNest Empty _ k q = mkNest k q
672 aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q)
673 -- p can't be Empty, so no need for mkNest
674
675 aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
676 aboveNest (TextBeside s sl p) g k q = k1 `seq` textBeside_ s sl rest
677 where
678 k1 = k - sl
679 rest = case p of
680 Empty -> nilAboveNest g k1 q
681 _ -> aboveNest p g k1 q
682 aboveNest (Above {}) _ _ _ = error "aboveNest Above"
683 aboveNest (Beside {}) _ _ _ = error "aboveNest Beside"
684
685
686 nilAboveNest :: Bool -> Int -> RDoc -> RDoc
687 -- Specification: text s <> nilaboveNest g k q
688 -- = text s <> (text "" $g$ nest k q)
689
690 nilAboveNest _ k _ | k `seq` False = undefined
691 nilAboveNest _ _ Empty = Empty -- Here's why the "text s <>" is in the spec!
692 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
693
694 nilAboveNest g k q | (not g) && (k > 0) -- No newline if no overlap
695 = textBeside_ (Str (spaces k)) k q
696 | otherwise -- Put them really above
697 = nilAbove_ (mkNest k q)
698
699 -- ---------------------------------------------------------------------------
700 -- Horizontal composition @<>@
701
702 beside_ :: Doc -> Bool -> Doc -> Doc
703 beside_ p _ Empty = p
704 beside_ Empty _ q = q
705 beside_ p g q = Beside p g q
706
707 p <> q = beside_ p False q
708 p <+> q = beside_ p True q
709
710 beside :: Doc -> Bool -> RDoc -> RDoc
711 -- Specification: beside g p q = p <g> q
712
713 beside NoDoc _ _ = NoDoc
714 beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q)
715 beside Empty _ q = q
716 beside (Nest k p) g q = nest_ k (beside p g q) -- p non-empty
717 beside p@(Beside p1 g1 q1) g2 q2
718 {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2
719 [ && (op1 == <> || op1 == <+>) ] -}
720 | g1 == g2 = beside p1 g1 (beside q1 g2 q2)
721 | otherwise = beside (reduceDoc p) g2 q2
722 beside p@(Above _ _ _) g q = beside (reduceDoc p) g q
723 beside (NilAbove p) g q = nilAbove_ (beside p g q)
724 beside (TextBeside s sl p) g q = textBeside_ s sl rest
725 where
726 rest = case p of
727 Empty -> nilBeside g q
728 _ -> beside p g q
729
730
731 nilBeside :: Bool -> RDoc -> RDoc
732 -- Specification: text "" <> nilBeside g p
733 -- = text "" <g> p
734
735 nilBeside _ Empty = Empty -- Hence the text "" in the spec
736 nilBeside g (Nest _ p) = nilBeside g p
737 nilBeside g p | g = textBeside_ space_text 1 p
738 | otherwise = p
739
740 -- ---------------------------------------------------------------------------
741 -- Separate, @sep@, Hughes version
742
743 -- Specification: sep ps = oneLiner (hsep ps)
744 -- `union`
745 -- vcat ps
746
747 sep = sepX True -- Separate with spaces
748 cat = sepX False -- Don't
749
750 sepX :: Bool -> [Doc] -> Doc
751 sepX _ [] = empty
752 sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
753
754
755 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
756 -- = oneLiner (x <g> nest k (hsep ys))
757 -- `union` x $$ nest k (vcat ys)
758
759 sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
760 sep1 _ _ k _ | k `seq` False = undefined
761 sep1 _ NoDoc _ _ = NoDoc
762 sep1 g (p `Union` q) k ys = sep1 g p k ys
763 `union_`
764 (aboveNest q False k (reduceDoc (vcat ys)))
765
766 sep1 g Empty k ys = mkNest k (sepX g ys)
767 sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys)
768
769 sep1 _ (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
770 sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)
771 sep1 _ (Above {}) _ _ = error "sep1 Above"
772 sep1 _ (Beside {}) _ _ = error "sep1 Beside"
773
774 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
775 -- Called when we have already found some text in the first item
776 -- We have to eat up nests
777
778 sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc
779
780 sepNB g (Nest _ p) k ys = sepNB g p k ys -- Never triggered, because of invariant (2)
781
782 sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))
783 `mkUnion`
784 nilAboveNest True k (reduceDoc (vcat ys))
785 where
786 rest | g = hsep ys
787 | otherwise = hcat ys
788
789 sepNB g p k ys = sep1 g p k ys
790
791 -- ---------------------------------------------------------------------------
792 -- @fill@
793
794 fsep = fill True
795 fcat = fill False
796
797 -- Specification:
798 --
799 -- fill g docs = fillIndent 0 docs
800 --
801 -- fillIndent k [] = []
802 -- fillIndent k [p] = p
803 -- fillIndent k (p1:p2:ps) =
804 -- oneLiner p1 <g> fillIndent (k + length p1 + g ? 1 : 0) (remove_nests (oneLiner p2) : ps)
805 -- `Union`
806 -- (p1 $*$ nest (-k) (fillIndent 0 ps))
807 --
808 -- $*$ is defined for layouts (not Docs) as
809 -- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2
810 -- | otherwise = layout1 $+$ layout2
811
812 fill :: Bool -> [Doc] -> RDoc
813 fill _ [] = empty
814 fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
815
816
817 fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
818 fill1 _ _ k _ | k `seq` False = undefined
819 fill1 _ NoDoc _ _ = NoDoc
820 fill1 g (p `Union` q) k ys = fill1 g p k ys
821 `union_`
822 (aboveNest q False k (fill g ys))
823
824 fill1 g Empty k ys = mkNest k (fill g ys)
825 fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys)
826
827 fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
828 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
829 fill1 _ (Above {}) _ _ = error "fill1 Above"
830 fill1 _ (Beside {}) _ _ = error "fill1 Beside"
831
832 fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc
833 fillNB _ _ k _ | k `seq` False = undefined
834 fillNB g (Nest _ p) k ys = fillNB g p k ys -- Never triggered, because of invariant (2)
835 fillNB _ Empty _ [] = Empty
836 fillNB g Empty k (Empty:ys) = fillNB g Empty k ys
837 fillNB g Empty k (y:ys) = fillNBE g k y ys
838 fillNB g p k ys = fill1 g p k ys
839
840 fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc
841 fillNBE g k y ys = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k1 ys)
842 `mkUnion`
843 nilAboveNest True k (fill g (y:ys))
844 where
845 k1 | g = k - 1
846 | otherwise = k
847
848 elideNest :: Doc -> Doc
849 elideNest (Nest _ d) = d
850 elideNest d = d
851
852 -- ---------------------------------------------------------------------------
853 -- Selecting the best layout
854
855 best :: Mode
856 -> Int -- Line length
857 -> Int -- Ribbon length
858 -> RDoc
859 -> RDoc -- No unions in here!
860
861 best OneLineMode _ _ p0
862 = get p0 -- unused, due to the use of easy_display in full_render
863 where
864 get Empty = Empty
865 get NoDoc = NoDoc
866 get (NilAbove p) = nilAbove_ (get p)
867 get (TextBeside s sl p) = textBeside_ s sl (get p)
868 get (Nest _ p) = get p -- Elide nest
869 get (p `Union` q) = first (get p) (get q)
870 get (Above {}) = error "best OneLineMode get Above"
871 get (Beside {}) = error "best OneLineMode get Beside"
872
873 best _ w0 r p0
874 = get w0 p0
875 where
876 get :: Int -- (Remaining) width of line
877 -> Doc -> Doc
878 get w _ | w==0 && False = undefined
879 get _ Empty = Empty
880 get _ NoDoc = NoDoc
881 get w (NilAbove p) = nilAbove_ (get w p)
882 get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
883 get w (Nest k p) = nest_ k (get (w - k) p)
884 get w (p `Union` q) = nicest w r (get w p) (get w q)
885 get _ (Above {}) = error "best get Above"
886 get _ (Beside {}) = error "best get Beside"
887
888 get1 :: Int -- (Remaining) width of line
889 -> Int -- Amount of first line already eaten up
890 -> Doc -- This is an argument to TextBeside => eat Nests
891 -> Doc -- No unions in here!
892
893 get1 w _ _ | w==0 && False = undefined
894 get1 _ _ Empty = Empty
895 get1 _ _ NoDoc = NoDoc
896 get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p)
897 get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)
898 get1 w sl (Nest _ p) = get1 w sl p
899 get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
900 (get1 w sl q)
901 get1 _ _ (Above {}) = error "best get1 Above"
902 get1 _ _ (Beside {}) = error "best get1 Beside"
903
904 nicest :: Int -> Int -> Doc -> Doc -> Doc
905 nicest w r p q = nicest1 w r 0 p q
906
907 nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc
908 nicest1 w r sl p q | fits ((w `minn` r) - sl) p = p
909 | otherwise = q
910
911 fits :: Int -- Space available
912 -> Doc
913 -> Bool -- True if *first line* of Doc fits in space available
914
915 fits n _ | n < 0 = False
916 fits _ NoDoc = False
917 fits _ Empty = True
918 fits _ (NilAbove _) = True
919 fits n (TextBeside _ sl p) = fits (n - sl) p
920 fits _ (Above {}) = error "fits Above"
921 fits _ (Beside {}) = error "fits Beside"
922 fits _ (Union {}) = error "fits Union"
923 fits _ (Nest {}) = error "fits Nest"
924
925 minn :: Int -> Int -> Int
926 minn x y | x < y = x
927 | otherwise = y
928
929 -- @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
930 -- @first@ returns its first argument if it is non-empty, otherwise its second.
931
932 first :: Doc -> Doc -> Doc
933 first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused
934 | otherwise = q
935
936 nonEmptySet :: Doc -> Bool
937 nonEmptySet NoDoc = False
938 nonEmptySet (_ `Union` _) = True
939 nonEmptySet Empty = True
940 nonEmptySet (NilAbove _) = True -- NoDoc always in first line
941 nonEmptySet (TextBeside _ _ p) = nonEmptySet p
942 nonEmptySet (Nest _ p) = nonEmptySet p
943 nonEmptySet (Above {}) = error "nonEmptySet Above"
944 nonEmptySet (Beside {}) = error "nonEmptySet Beside"
945
946 -- @oneLiner@ returns the one-line members of the given set of @Doc@s.
947
948 oneLiner :: Doc -> Doc
949 oneLiner NoDoc = NoDoc
950 oneLiner Empty = Empty
951 oneLiner (NilAbove _) = NoDoc
952 oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
953 oneLiner (Nest k p) = nest_ k (oneLiner p)
954 oneLiner (p `Union` _) = oneLiner p
955 oneLiner (Above {}) = error "oneLiner Above"
956 oneLiner (Beside {}) = error "oneLiner Beside"
957
958
959 -- ---------------------------------------------------------------------------
960 -- Displaying the best layout
961
962 renderStyle the_style doc
963 = fullRender (mode the_style)
964 (lineLength the_style)
965 (ribbonsPerLine the_style)
966 string_txt
967 ""
968 doc
969
970 render doc = showDoc doc ""
971
972 showDoc :: Doc -> String -> String
973 showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc
974
975 string_txt :: TextDetails -> String -> String
976 string_txt (Chr c) s = c:s
977 string_txt (Str s1) s2 = s1 ++ s2
978 string_txt (PStr s1) s2 = s1 ++ s2
979
980
981 fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc)
982 fullRender LeftMode _ _ txt end doc = easy_display nl_text txt end (reduceDoc doc)
983
984 fullRender the_mode line_length ribbons_per_line txt end doc
985 = display the_mode line_length ribbon_length txt end best_doc
986 where
987 best_doc = best the_mode hacked_line_length ribbon_length (reduceDoc doc)
988
989 hacked_line_length, ribbon_length :: Int
990 ribbon_length = round (fromIntegral line_length / ribbons_per_line)
991 hacked_line_length = case the_mode of
992 ZigZagMode -> maxBound
993 _ -> line_length
994
995 display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a
996 display the_mode page_width ribbon_width txt end doc
997 = case page_width - ribbon_width of { gap_width ->
998 case gap_width `quot` 2 of { shift ->
999 let
1000 lay k _ | k `seq` False = undefined
1001 lay k (Nest k1 p) = lay (k + k1) p
1002 lay _ Empty = end
1003 lay _ (Above {}) = error "display lay Above"
1004 lay _ (Beside {}) = error "display lay Beside"
1005 lay _ NoDoc = error "display lay NoDoc"
1006 lay _ (Union {}) = error "display lay Union"
1007
1008 lay k (NilAbove p) = nl_text `txt` lay k p
1009
1010 lay k (TextBeside s sl p)
1011 = case the_mode of
1012 ZigZagMode | k >= gap_width
1013 -> nl_text `txt` (
1014 Str (multi_ch shift '/') `txt` (
1015 nl_text `txt` (
1016 lay1 (k - shift) s sl p)))
1017
1018 | k < 0
1019 -> nl_text `txt` (
1020 Str (multi_ch shift '\\') `txt` (
1021 nl_text `txt` (
1022 lay1 (k + shift) s sl p )))
1023
1024 _ -> lay1 k s sl p
1025
1026 lay1 k _ sl _ | k+sl `seq` False = undefined
1027 lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p)
1028
1029 lay2 k _ | k `seq` False = undefined
1030 lay2 k (NilAbove p) = nl_text `txt` lay k p
1031 lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p)
1032 lay2 k (Nest _ p) = lay2 k p
1033 lay2 _ Empty = end
1034 lay2 _ (Above {}) = error "display lay2 Above"
1035 lay2 _ (Beside {}) = error "display lay2 Beside"
1036 lay2 _ NoDoc = error "display lay2 NoDoc"
1037 lay2 _ (Union {}) = error "display lay2 Union"
1038 in
1039 lay 0 doc
1040 }}
1041
1042 cant_fail :: a
1043 cant_fail = error "easy_display: NoDoc"
1044
1045 easy_display :: TextDetails -> (TextDetails -> a -> a) -> a -> Doc -> a
1046 easy_display nl_space_text txt end doc
1047 = lay doc cant_fail
1048 where
1049 lay NoDoc no_doc = no_doc
1050 lay (Union _p q) _ = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc
1051 lay (Nest _ p) no_doc = lay p no_doc
1052 lay Empty _ = end
1053 lay (NilAbove p) _ = nl_space_text `txt` lay p cant_fail -- NoDoc always on first line
1054 lay (TextBeside s _ p) no_doc = s `txt` lay p no_doc
1055 lay (Above {}) _ = error "easy_display Above"
1056 lay (Beside {}) _ = error "easy_display Beside"
1057
1058 -- OLD version: we shouldn't rely on tabs being 8 columns apart in the output.
1059 -- indent n | n >= 8 = '\t' : indent (n - 8)
1060 -- | otherwise = spaces n
1061 indent :: Int -> String
1062 indent n = spaces n
1063
1064 multi_ch :: Int -> Char -> String
1065 multi_ch 0 _ = ""
1066 multi_ch n ch = ch : multi_ch (n - 1) ch
1067
1068 -- (spaces n) generates a list of n spaces
1069 --
1070 -- returns the empty string on negative argument.
1071 --
1072 spaces :: Int -> String
1073 spaces n
1074 {-
1075 | n < 0 = trace "Warning: negative indentation" ""
1076 -}
1077 | n <= 0 = ""
1078 | otherwise = ' ' : spaces (n - 1)
1079
1080 {-
1081 Q: What is the reason for negative indentation (i.e. argument to indent
1082 is < 0) ?
1083
1084 A:
1085 This indicates an error in the library client's code.
1086 If we compose a <> b, and the first line of b is more indented than some
1087 other lines of b, the law <n6> (<> eats nests) may cause the pretty
1088 printer to produce an invalid layout:
1089
1090 doc |0123345
1091 ------------------
1092 d1 |a...|
1093 d2 |...b|
1094 |c...|
1095
1096 d1<>d2 |ab..|
1097 c|....|
1098
1099 Consider a <> b, let `s' be the length of the last line of `a', `k' the
1100 indentation of the first line of b, and `k0' the indentation of the
1101 left-most line b_i of b.
1102
1103 The produced layout will have negative indentation if `k - k0 > s', as
1104 the first line of b will be put on the (s+1)th column, effectively
1105 translating b horizontally by (k-s). Now if the i^th line of b has an
1106 indentation k0 < (k-s), it is translated out-of-page, causing
1107 `negative indentation'.
1108 -}
1109