fix up indent code
[packages/pretty.git] / src / Text / PrettyPrint / HughesPJ.hs
1 {-# OPTIONS_HADDOCK not-home #-}
2 {-# LANGUAGE BangPatterns #-}
3 #if __GLASGOW_HASKELL__ >= 701
4 {-# LANGUAGE Safe #-}
5 #endif
6
7 -----------------------------------------------------------------------------
8 -- |
9 -- Module : Text.PrettyPrint.HughesPJ
10 -- Copyright : (c) The University of Glasgow 2001
11 -- License : BSD-style (see the file LICENSE)
12 --
13 -- Maintainer : David Terei <dave.terei@gmail.com>
14 -- Stability : stable
15 -- Portability : portable
16 --
17 -- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators
18 --
19 -- Based on /The Design of a Pretty-printing Library/
20 -- in Advanced Functional Programming,
21 -- Johan Jeuring and Erik Meijer (eds), LNCS 925
22 -- <http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps>
23 --
24 -----------------------------------------------------------------------------
25
26 #ifndef TESTING
27 module Text.PrettyPrint.HughesPJ (
28
29 -- * The document type
30 Doc, TextDetails(..),
31
32 -- * Constructing documents
33
34 -- ** Converting values into documents
35 char, text, ptext, sizedText, zeroWidthText,
36 int, integer, float, double, rational,
37
38 -- ** Simple derived documents
39 semi, comma, colon, space, equals,
40 lparen, rparen, lbrack, rbrack, lbrace, rbrace,
41
42 -- ** Wrapping documents in delimiters
43 parens, brackets, braces, quotes, doubleQuotes,
44
45 -- ** Combining documents
46 empty,
47 (<>), (<+>), hcat, hsep,
48 ($$), ($+$), vcat,
49 sep, cat,
50 fsep, fcat,
51 nest,
52 hang, punctuate,
53
54 -- * Predicates on documents
55 isEmpty,
56
57 -- * Utility functions for documents
58 first, reduceDoc,
59 -- TODO: Should these be exported? Previously they weren't
60
61 -- * Rendering documents
62
63 -- ** Default rendering
64 render,
65
66 -- ** Rendering with a particular style
67 Style(..),
68 style,
69 renderStyle,
70 Mode(..),
71
72 -- ** General rendering
73 fullRender
74
75 ) where
76 #endif
77
78 import Data.Monoid ( Monoid(mempty, mappend) )
79 import Data.String ( IsString(fromString) )
80
81 -- ---------------------------------------------------------------------------
82 -- The Doc calculus
83
84 {-
85 Laws for $$
86 ~~~~~~~~~~~
87 <a1> (x $$ y) $$ z = x $$ (y $$ z)
88 <a2> empty $$ x = x
89 <a3> x $$ empty = x
90
91 ...ditto $+$...
92
93 Laws for <>
94 ~~~~~~~~~~~
95 <b1> (x <> y) <> z = x <> (y <> z)
96 <b2> empty <> x = empty
97 <b3> x <> empty = x
98
99 ...ditto <+>...
100
101 Laws for text
102 ~~~~~~~~~~~~~
103 <t1> text s <> text t = text (s++t)
104 <t2> text "" <> x = x, if x non-empty
105
106 ** because of law n6, t2 only holds if x doesn't
107 ** start with `nest'.
108
109
110 Laws for nest
111 ~~~~~~~~~~~~~
112 <n1> nest 0 x = x
113 <n2> nest k (nest k' x) = nest (k+k') x
114 <n3> nest k (x <> y) = nest k x <> nest k y
115 <n4> nest k (x $$ y) = nest k x $$ nest k y
116 <n5> nest k empty = empty
117 <n6> x <> nest k y = x <> y, if x non-empty
118
119 ** Note the side condition on <n6>! It is this that
120 ** makes it OK for empty to be a left unit for <>.
121
122 Miscellaneous
123 ~~~~~~~~~~~~~
124 <m1> (text s <> x) $$ y = text s <> ((text "" <> x) $$
125 nest (-length s) y)
126
127 <m2> (x $$ y) <> z = x $$ (y <> z)
128 if y non-empty
129
130
131 Laws for list versions
132 ~~~~~~~~~~~~~~~~~~~~~~
133 <l1> sep (ps++[empty]++qs) = sep (ps ++ qs)
134 ...ditto hsep, hcat, vcat, fill...
135
136 <l2> nest k (sep ps) = sep (map (nest k) ps)
137 ...ditto hsep, hcat, vcat, fill...
138
139 Laws for oneLiner
140 ~~~~~~~~~~~~~~~~~
141 <o1> oneLiner (nest k p) = nest k (oneLiner p)
142 <o2> oneLiner (x <> y) = oneLiner x <> oneLiner y
143
144 You might think that the following verion of <m1> would
145 be neater:
146
147 <3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$
148 nest (-length s) y)
149
150 But it doesn't work, for if x=empty, we would have
151
152 text s $$ y = text s <> (empty $$ nest (-length s) y)
153 = text s <> nest (-length s) y
154 -}
155
156 -- ---------------------------------------------------------------------------
157 -- Operator fixity
158
159 infixl 6 <>
160 infixl 6 <+>
161 infixl 5 $$, $+$
162
163 -- ---------------------------------------------------------------------------
164 -- The Doc data type
165
166 -- | The abstract type of documents.
167 -- A Doc represents a *set* of layouts. A Doc with
168 -- no occurrences of Union or NoDoc represents just one layout.
169 data Doc
170 = Empty -- empty
171 | NilAbove Doc -- text "" $$ x
172 | TextBeside !TextDetails {-# UNPACK #-} !Int Doc -- text s <> x
173 | Nest {-# UNPACK #-} !Int Doc -- nest k x
174 | Union Doc Doc -- ul `union` ur
175 | NoDoc -- The empty set of documents
176 | Beside Doc Bool Doc -- True <=> space between
177 | Above Doc Bool Doc -- True <=> never overlap
178
179 {-
180 Here are the invariants:
181
182 1) The argument of NilAbove is never Empty. Therefore
183 a NilAbove occupies at least two lines.
184
185 2) The argument of @TextBeside@ is never @Nest@.
186
187 3) The layouts of the two arguments of @Union@ both flatten to the same
188 string.
189
190 4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
191
192 5) A @NoDoc@ may only appear on the first line of the left argument of an
193 union. Therefore, the right argument of an union can never be equivalent
194 to the empty set (@NoDoc@).
195
196 6) An empty document is always represented by @Empty@. It can't be
197 hidden inside a @Nest@, or a @Union@ of two @Empty@s.
198
199 7) The first line of every layout in the left argument of @Union@ is
200 longer than the first line of any layout in the right argument.
201 (1) ensures that the left argument has a first line. In view of
202 (3), this invariant means that the right argument must have at
203 least two lines.
204
205 Notice the difference between
206 * NoDoc (no documents)
207 * Empty (one empty document; no height and no width)
208 * text "" (a document containing the empty string;
209 one line high, but has no width)
210 -}
211
212
213 -- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside.
214 type RDoc = Doc
215
216 -- | The TextDetails data type
217 --
218 -- A TextDetails represents a fragment of text that will be
219 -- output at some point.
220 data TextDetails = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment
221 | Str String -- ^ A whole String fragment
222 | PStr String -- ^ Used to represent a Fast String fragment
223 -- but now deprecated and identical to the
224 -- Str constructor.
225
226 -- Combining @Doc@ values
227 instance Monoid Doc where
228 mempty = empty
229 mappend = (<>)
230
231 instance IsString Doc where
232 fromString = text
233
234 instance Show Doc where
235 showsPrec _ doc cont = fullRender (mode style) (lineLength style)
236 (ribbonsPerLine style)
237 txtPrinter cont doc
238
239 -- ---------------------------------------------------------------------------
240 -- Values and Predicates on GDocs and TextDetails
241
242 -- | A document of height and width 1, containing a literal character.
243 char :: Char -> Doc
244 char c = textBeside_ (Chr c) 1 Empty
245
246 -- | A document of height 1 containing a literal string.
247 -- 'text' satisfies the following laws:
248 --
249 -- * @'text' s '<>' 'text' t = 'text' (s'++'t)@
250 --
251 -- * @'text' \"\" '<>' x = x@, if @x@ non-empty
252 --
253 -- The side condition on the last law is necessary because @'text' \"\"@
254 -- has height 1, while 'empty' has no height.
255 text :: String -> Doc
256 text s = case length s of {sl -> textBeside_ (Str s) sl Empty}
257
258 -- | Same as @text@. Used to be used for Bytestrings.
259 ptext :: String -> Doc
260 ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty}
261
262 -- | Some text with any width. (@text s = sizedText (length s) s@)
263 sizedText :: Int -> String -> Doc
264 sizedText l s = textBeside_ (Str s) l Empty
265
266 -- | Some text, but without any width. Use for non-printing text
267 -- such as a HTML or Latex tags
268 zeroWidthText :: String -> Doc
269 zeroWidthText = sizedText 0
270
271 -- | The empty document, with no height and no width.
272 -- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere
273 -- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc.
274 empty :: Doc
275 empty = Empty
276
277 -- | Returns 'True' if the document is empty
278 isEmpty :: Doc -> Bool
279 isEmpty Empty = True
280 isEmpty _ = False
281
282 -- | Produce spacing for indenting the amount specified.
283 --
284 -- an old version inserted tabs being 8 columns apart in the output.
285 indent :: Int -> String
286 indent !n = replicate n ' '
287
288 {-
289 Q: What is the reason for negative indentation (i.e. argument to indent
290 is < 0) ?
291
292 A:
293 This indicates an error in the library client's code.
294 If we compose a <> b, and the first line of b is more indented than some
295 other lines of b, the law <n6> (<> eats nests) may cause the pretty
296 printer to produce an invalid layout:
297
298 doc |0123345
299 ------------------
300 d1 |a...|
301 d2 |...b|
302 |c...|
303
304 d1<>d2 |ab..|
305 c|....|
306
307 Consider a <> b, let `s' be the length of the last line of `a', `k' the
308 indentation of the first line of b, and `k0' the indentation of the
309 left-most line b_i of b.
310
311 The produced layout will have negative indentation if `k - k0 > s', as
312 the first line of b will be put on the (s+1)th column, effectively
313 translating b horizontally by (k-s). Now if the i^th line of b has an
314 indentation k0 < (k-s), it is translated out-of-page, causing
315 `negative indentation'.
316 -}
317
318
319 semi :: Doc -- ^ A ';' character
320 comma :: Doc -- ^ A ',' character
321 colon :: Doc -- ^ A ':' character
322 space :: Doc -- ^ A space character
323 equals :: Doc -- ^ A '=' character
324 lparen :: Doc -- ^ A '(' character
325 rparen :: Doc -- ^ A ')' character
326 lbrack :: Doc -- ^ A '[' character
327 rbrack :: Doc -- ^ A ']' character
328 lbrace :: Doc -- ^ A '{' character
329 rbrace :: Doc -- ^ A '}' character
330 semi = char ';'
331 comma = char ','
332 colon = char ':'
333 space = char ' '
334 equals = char '='
335 lparen = char '('
336 rparen = char ')'
337 lbrack = char '['
338 rbrack = char ']'
339 lbrace = char '{'
340 rbrace = char '}'
341
342 space_text, nl_text :: TextDetails
343 space_text = Chr ' '
344 nl_text = Chr '\n'
345
346 int :: Int -> Doc -- ^ @int n = text (show n)@
347 integer :: Integer -> Doc -- ^ @integer n = text (show n)@
348 float :: Float -> Doc -- ^ @float n = text (show n)@
349 double :: Double -> Doc -- ^ @double n = text (show n)@
350 rational :: Rational -> Doc -- ^ @rational n = text (show n)@
351 int n = text (show n)
352 integer n = text (show n)
353 float n = text (show n)
354 double n = text (show n)
355 rational n = text (show n)
356
357 parens :: Doc -> Doc -- ^ Wrap document in @(...)@
358 brackets :: Doc -> Doc -- ^ Wrap document in @[...]@
359 braces :: Doc -> Doc -- ^ Wrap document in @{...}@
360 quotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@
361 doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@
362 quotes p = char '\'' <> p <> char '\''
363 doubleQuotes p = char '"' <> p <> char '"'
364 parens p = char '(' <> p <> char ')'
365 brackets p = char '[' <> p <> char ']'
366 braces p = char '{' <> p <> char '}'
367
368
369 -- ---------------------------------------------------------------------------
370 -- Structural operations on GDocs
371
372 -- | Perform some simplification of a built up @GDoc@.
373 reduceDoc :: Doc -> RDoc
374 reduceDoc (Beside p g q) = beside p g (reduceDoc q)
375 reduceDoc (Above p g q) = above p g (reduceDoc q)
376 reduceDoc p = p
377
378 -- | List version of '<>'.
379 hcat :: [Doc] -> Doc
380 hcat = reduceAB . foldr (beside_' False) empty
381
382 -- | List version of '<+>'.
383 hsep :: [Doc] -> Doc
384 hsep = reduceAB . foldr (beside_' True) empty
385
386 -- | List version of '$$'.
387 vcat :: [Doc] -> Doc
388 vcat = reduceAB . foldr (above_' False) empty
389
390 -- | Nest (or indent) a document by a given number of positions
391 -- (which may also be negative). 'nest' satisfies the laws:
392 --
393 -- * @'nest' 0 x = x@
394 --
395 -- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@
396 --
397 -- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@
398 --
399 -- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@
400 --
401 -- * @'nest' k 'empty' = 'empty'@
402 --
403 -- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty
404 --
405 -- The side condition on the last law is needed because
406 -- 'empty' is a left identity for '<>'.
407 nest :: Int -> Doc -> Doc
408 nest k p = mkNest k (reduceDoc p)
409
410 -- | @hang d1 n d2 = sep [d1, nest n d2]@
411 hang :: Doc -> Int -> Doc -> Doc
412 hang d1 n d2 = sep [d1, nest n d2]
413
414 -- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@
415 punctuate :: Doc -> [Doc] -> [Doc]
416 punctuate _ [] = []
417 punctuate p (x:xs) = go x xs
418 where go y [] = [y]
419 go y (z:zs) = (y <> p) : go z zs
420
421 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
422 mkNest :: Int -> Doc -> Doc
423 mkNest k _ | k `seq` False = undefined
424 mkNest k (Nest k1 p) = mkNest (k + k1) p
425 mkNest _ NoDoc = NoDoc
426 mkNest _ Empty = Empty
427 mkNest 0 p = p
428 mkNest k p = nest_ k p
429
430 -- mkUnion checks for an empty document
431 mkUnion :: Doc -> Doc -> Doc
432 mkUnion Empty _ = Empty
433 mkUnion p q = p `union_` q
434
435 beside_' :: Bool -> Doc -> Doc -> Doc
436 beside_' _ p Empty = p
437 beside_' g p q = Beside p g q
438
439 above_' :: Bool -> Doc -> Doc -> Doc
440 above_' _ p Empty = p
441 above_' g p q = Above p g q
442
443 reduceAB :: Doc -> Doc
444 reduceAB (Above Empty _ q) = q
445 reduceAB (Beside Empty _ q) = q
446 reduceAB doc = doc
447
448 nilAbove_ :: RDoc -> RDoc
449 nilAbove_ p = NilAbove p
450
451 -- Arg of a TextBeside is always an RDoc
452 textBeside_ :: TextDetails -> Int -> RDoc -> RDoc
453 textBeside_ s sl p = TextBeside s sl p
454
455 nest_ :: Int -> RDoc -> RDoc
456 nest_ k p = Nest k p
457
458 union_ :: RDoc -> RDoc -> RDoc
459 union_ p q = Union p q
460
461
462 -- ---------------------------------------------------------------------------
463 -- Vertical composition @$$@
464
465 -- | Above, except that if the last line of the first argument stops
466 -- at least one position before the first line of the second begins,
467 -- these two lines are overlapped. For example:
468 --
469 -- > text "hi" $$ nest 5 (text "there")
470 --
471 -- lays out as
472 --
473 -- > hi there
474 --
475 -- rather than
476 --
477 -- > hi
478 -- > there
479 --
480 -- '$$' is associative, with identity 'empty', and also satisfies
481 --
482 -- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty.
483 --
484 ($$) :: Doc -> Doc -> Doc
485 p $$ q = above_ p False q
486
487 -- | Above, with no overlapping.
488 -- '$+$' is associative, with identity 'empty'.
489 ($+$) :: Doc -> Doc -> Doc
490 p $+$ q = above_ p True q
491
492 above_ :: Doc -> Bool -> Doc -> Doc
493 above_ p _ Empty = p
494 above_ Empty _ q = q
495 above_ p g q = Above p g q
496
497 above :: Doc -> Bool -> RDoc -> RDoc
498 above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
499 above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q)
500 above p g q = aboveNest p g 0 (reduceDoc q)
501
502 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
503 aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
504 aboveNest _ _ k _ | k `seq` False = undefined
505 aboveNest NoDoc _ _ _ = NoDoc
506 aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
507 aboveNest p2 g k q
508
509 aboveNest Empty _ k q = mkNest k q
510 aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q)
511 -- p can't be Empty, so no need for mkNest
512
513 aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
514 aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
515 where
516 !k1 = k - sl
517 rest = case p of
518 Empty -> nilAboveNest g k1 q
519 _ -> aboveNest p g k1 q
520 aboveNest (Above {}) _ _ _ = error "aboveNest Above"
521 aboveNest (Beside {}) _ _ _ = error "aboveNest Beside"
522
523 -- Specification: text s <> nilaboveNest g k q
524 -- = text s <> (text "" $g$ nest k q)
525 nilAboveNest :: Bool -> Int -> RDoc -> RDoc
526 nilAboveNest _ k _ | k `seq` False = undefined
527 nilAboveNest _ _ Empty = Empty
528 -- Here's why the "text s <>" is in the spec!
529 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
530 nilAboveNest g k q | not g && k > 0 -- No newline if no overlap
531 = textBeside_ (Str (indent k)) k q
532 | otherwise -- Put them really above
533 = nilAbove_ (mkNest k q)
534
535
536 -- ---------------------------------------------------------------------------
537 -- Horizontal composition @<>@
538
539 -- We intentionally avoid Data.Monoid.(<>) here due to interactions of
540 -- Data.Monoid.(<>) and (<+>). See
541 -- http://www.haskell.org/pipermail/libraries/2011-November/017066.html
542
543 -- | Beside.
544 -- '<>' is associative, with identity 'empty'.
545 (<>) :: Doc -> Doc -> Doc
546 p <> q = beside_ p False q
547
548 -- | Beside, separated by space, unless one of the arguments is 'empty'.
549 -- '<+>' is associative, with identity 'empty'.
550 (<+>) :: Doc -> Doc -> Doc
551 p <+> q = beside_ p True q
552
553 beside_ :: Doc -> Bool -> Doc -> Doc
554 beside_ p _ Empty = p
555 beside_ Empty _ q = q
556 beside_ p g q = Beside p g q
557
558 -- Specification: beside g p q = p <g> q
559 beside :: Doc -> Bool -> RDoc -> RDoc
560 beside NoDoc _ _ = NoDoc
561 beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q
562 beside Empty _ q = q
563 beside (Nest k p) g q = nest_ k $! beside p g q
564 beside p@(Beside p1 g1 q1) g2 q2
565 | g1 == g2 = beside p1 g1 $! beside q1 g2 q2
566 | otherwise = beside (reduceDoc p) g2 q2
567 beside p@(Above _ _ _) g q = let !d = reduceDoc p in beside d g q
568 beside (NilAbove p) g q = nilAbove_ $! beside p g q
569 beside (TextBeside s sl p) g q = textBeside_ s sl $! rest
570 where
571 rest = case p of
572 Empty -> nilBeside g q
573 _ -> beside p g q
574
575 -- Specification: text "" <> nilBeside g p
576 -- = text "" <g> p
577 nilBeside :: Bool -> RDoc -> RDoc
578 nilBeside _ Empty = Empty -- Hence the text "" in the spec
579 nilBeside g (Nest _ p) = nilBeside g p
580 nilBeside g p | g = textBeside_ space_text 1 p
581 | otherwise = p
582
583
584 -- ---------------------------------------------------------------------------
585 -- Separate, @sep@
586
587 -- Specification: sep ps = oneLiner (hsep ps)
588 -- `union`
589 -- vcat ps
590
591 -- | Either 'hsep' or 'vcat'.
592 sep :: [Doc] -> Doc
593 sep = sepX True -- Separate with spaces
594
595 -- | Either 'hcat' or 'vcat'.
596 cat :: [Doc] -> Doc
597 cat = sepX False -- Don't
598
599 sepX :: Bool -> [Doc] -> Doc
600 sepX _ [] = empty
601 sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
602
603
604 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
605 -- = oneLiner (x <g> nest k (hsep ys))
606 -- `union` x $$ nest k (vcat ys)
607 sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
608 sep1 _ _ k _ | k `seq` False = undefined
609 sep1 _ NoDoc _ _ = NoDoc
610 sep1 g (p `Union` q) k ys = sep1 g p k ys `union_`
611 aboveNest q False k (reduceDoc (vcat ys))
612
613 sep1 g Empty k ys = mkNest k (sepX g ys)
614 sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys)
615
616 sep1 _ (NilAbove p) k ys = nilAbove_
617 (aboveNest p False k (reduceDoc (vcat ys)))
618 sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)
619 sep1 _ (Above {}) _ _ = error "sep1 Above"
620 sep1 _ (Beside {}) _ _ = error "sep1 Beside"
621
622 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
623 -- Called when we have already found some text in the first item
624 -- We have to eat up nests
625 sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc
626 sepNB g (Nest _ p) k ys
627 = sepNB g p k ys -- Never triggered, because of invariant (2)
628 sepNB g Empty k ys
629 = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion`
630 -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...)
631 nilAboveNest False k (reduceDoc (vcat ys))
632 where
633 rest | g = hsep ys
634 | otherwise = hcat ys
635 sepNB g p k ys
636 = sep1 g p k ys
637
638
639 -- ---------------------------------------------------------------------------
640 -- @fill@
641
642 -- | \"Paragraph fill\" version of 'cat'.
643 fcat :: [Doc] -> Doc
644 fcat = fill False
645
646 -- | \"Paragraph fill\" version of 'sep'.
647 fsep :: [Doc] -> Doc
648 fsep = fill True
649
650 -- Specification:
651 --
652 -- fill g docs = fillIndent 0 docs
653 --
654 -- fillIndent k [] = []
655 -- fillIndent k [p] = p
656 -- fillIndent k (p1:p2:ps) =
657 -- oneLiner p1 <g> fillIndent (k + length p1 + g ? 1 : 0)
658 -- (remove_nests (oneLiner p2) : ps)
659 -- `Union`
660 -- (p1 $*$ nest (-k) (fillIndent 0 ps))
661 --
662 -- $*$ is defined for layouts (not Docs) as
663 -- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2
664 -- | otherwise = layout1 $+$ layout2
665
666 fill :: Bool -> [Doc] -> RDoc
667 fill _ [] = empty
668 fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
669
670 fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
671 fill1 _ _ k _ | k `seq` False = undefined
672 fill1 _ NoDoc _ _ = NoDoc
673 fill1 g (p `Union` q) k ys = fill1 g p k ys `union_`
674 aboveNest q False k (fill g ys)
675 fill1 g Empty k ys = mkNest k (fill g ys)
676 fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys)
677 fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
678 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
679 fill1 _ (Above {}) _ _ = error "fill1 Above"
680 fill1 _ (Beside {}) _ _ = error "fill1 Beside"
681
682 fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc
683 fillNB _ _ k _ | k `seq` False = undefined
684 fillNB g (Nest _ p) k ys = fillNB g p k ys
685 -- Never triggered, because of invariant (2)
686 fillNB _ Empty _ [] = Empty
687 fillNB g Empty k (Empty:ys) = fillNB g Empty k ys
688 fillNB g Empty k (y:ys) = fillNBE g k y ys
689 fillNB g p k ys = fill1 g p k ys
690
691
692 fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc
693 fillNBE g k y ys
694 = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys)
695 -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...)
696 `mkUnion` nilAboveNest False k (fill g (y:ys))
697 where k' = if g then k - 1 else k
698
699 elideNest :: Doc -> Doc
700 elideNest (Nest _ d) = d
701 elideNest d = d
702
703
704 -- ---------------------------------------------------------------------------
705 -- Selecting the best layout
706
707 best :: Int -- Line length
708 -> Int -- Ribbon length
709 -> RDoc
710 -> RDoc -- No unions in here!
711 best w0 r p0
712 = get w0 p0
713 where
714 get w _ | w == 0 && False = undefined
715 get _ Empty = Empty
716 get _ NoDoc = NoDoc
717 get w (NilAbove p) = nilAbove_ (get w p)
718 get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
719 get w (Nest k p) = nest_ k (get (w - k) p)
720 get w (p `Union` q) = nicest w r (get w p) (get w q)
721 get _ (Above {}) = error "best get Above"
722 get _ (Beside {}) = error "best get Beside"
723
724 get1 w _ _ | w == 0 && False = undefined
725 get1 _ _ Empty = Empty
726 get1 _ _ NoDoc = NoDoc
727 get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p)
728 get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)
729 get1 w sl (Nest _ p) = get1 w sl p
730 get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
731 (get1 w sl q)
732 get1 _ _ (Above {}) = error "best get1 Above"
733 get1 _ _ (Beside {}) = error "best get1 Beside"
734
735 nicest :: Int -> Int -> Doc -> Doc -> Doc
736 nicest !w !r p q = nicest1 w r 0 p q
737
738 nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc
739 nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p
740 | otherwise = q
741
742 fits :: Int -- Space available
743 -> Doc
744 -> Bool -- True if *first line* of Doc fits in space available
745 fits n _ | n < 0 = False
746 fits _ NoDoc = False
747 fits _ Empty = True
748 fits _ (NilAbove _) = True
749 fits n (TextBeside _ sl p) = fits (n - sl) p
750 fits _ (Above {}) = error "fits Above"
751 fits _ (Beside {}) = error "fits Beside"
752 fits _ (Union {}) = error "fits Union"
753 fits _ (Nest {}) = error "fits Nest"
754
755 -- | @first@ returns its first argument if it is non-empty, otherwise its second.
756 first :: Doc -> Doc -> Doc
757 first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused
758 | otherwise = q
759
760 nonEmptySet :: Doc -> Bool
761 nonEmptySet NoDoc = False
762 nonEmptySet (_ `Union` _) = True
763 nonEmptySet Empty = True
764 nonEmptySet (NilAbove _) = True
765 nonEmptySet (TextBeside _ _ p) = nonEmptySet p
766 nonEmptySet (Nest _ p) = nonEmptySet p
767 nonEmptySet (Above {}) = error "nonEmptySet Above"
768 nonEmptySet (Beside {}) = error "nonEmptySet Beside"
769
770 -- @oneLiner@ returns the one-line members of the given set of @GDoc@s.
771 oneLiner :: Doc -> Doc
772 oneLiner NoDoc = NoDoc
773 oneLiner Empty = Empty
774 oneLiner (NilAbove _) = NoDoc
775 oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
776 oneLiner (Nest k p) = nest_ k (oneLiner p)
777 oneLiner (p `Union` _) = oneLiner p
778 oneLiner (Above {}) = error "oneLiner Above"
779 oneLiner (Beside {}) = error "oneLiner Beside"
780
781
782 -- ---------------------------------------------------------------------------
783 -- Rendering
784
785 -- | A rendering style.
786 data Style
787 = Style { mode :: Mode -- ^ The rendering mode
788 , lineLength :: Int -- ^ Length of line, in chars
789 , ribbonsPerLine :: Float -- ^ Ratio of ribbon length to line length
790 }
791
792 -- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@).
793 style :: Style
794 style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode }
795
796 -- | Rendering mode.
797 data Mode = PageMode -- ^ Normal
798 | ZigZagMode -- ^ With zig-zag cuts
799 | LeftMode -- ^ No indentation, infinitely long lines
800 | OneLineMode -- ^ All on one line
801
802 -- | Render the @Doc@ to a String using the default @Style@.
803 render :: Doc -> String
804 render doc = fullRender (mode style) (lineLength style) (ribbonsPerLine style)
805 txtPrinter "" doc
806
807 -- | Render the @Doc@ to a String using the given @Style@.
808 renderStyle :: Style -> Doc -> String
809 renderStyle s doc = fullRender (mode s) (lineLength s) (ribbonsPerLine s)
810 txtPrinter "" doc
811
812 -- | Default TextDetails printer
813 txtPrinter :: TextDetails -> String -> String
814 txtPrinter (Chr c) s = c:s
815 txtPrinter (Str s1) s2 = s1 ++ s2
816 txtPrinter (PStr s1) s2 = s1 ++ s2
817
818 -- | The general rendering interface.
819 fullRender :: Mode -- ^ Rendering mode
820 -> Int -- ^ Line length
821 -> Float -- ^ Ribbons per line
822 -> (TextDetails -> a -> a) -- ^ What to do with text
823 -> a -- ^ What to do at the end
824 -> Doc -- ^ The document
825 -> a -- ^ Result
826 fullRender OneLineMode _ _ txt end doc
827 = easy_display space_text (\_ y -> y) txt end (reduceDoc doc)
828 fullRender LeftMode _ _ txt end doc
829 = easy_display nl_text first txt end (reduceDoc doc)
830
831 fullRender m lineLen ribbons txt rest doc
832 = display m lineLen ribbonLen txt rest doc'
833 where
834 doc' = best bestLineLen ribbonLen (reduceDoc doc)
835
836 bestLineLen, ribbonLen :: Int
837 ribbonLen = round (fromIntegral lineLen / ribbons)
838 bestLineLen = case m of
839 ZigZagMode -> maxBound
840 _ -> lineLen
841
842 easy_display :: TextDetails
843 -> (Doc -> Doc -> Doc)
844 -> (TextDetails -> a -> a)
845 -> a
846 -> Doc
847 -> a
848 easy_display nl_space_text choose txt end doc
849 = lay doc
850 where
851 lay NoDoc = error "easy_display: NoDoc"
852 lay (Union p q) = lay (choose p q)
853 lay (Nest _ p) = lay p
854 lay Empty = end
855 lay (NilAbove p) = nl_space_text `txt` lay p
856 lay (TextBeside s _ p) = s `txt` lay p
857 lay (Above {}) = error "easy_display Above"
858 lay (Beside {}) = error "easy_display Beside"
859
860 display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a
861 display m !page_width !ribbon_width txt end doc
862 = case page_width - ribbon_width of { gap_width ->
863 case gap_width `quot` 2 of { shift ->
864 let
865 lay k _ | k `seq` False = undefined
866 lay k (Nest k1 p) = lay (k + k1) p
867 lay _ Empty = end
868 lay k (NilAbove p) = nl_text `txt` lay k p
869 lay k (TextBeside s sl p)
870 = case m of
871 ZigZagMode | k >= gap_width
872 -> nl_text `txt` (
873 Str (replicate shift '/') `txt` (
874 nl_text `txt`
875 lay1 (k - shift) s sl p ))
876
877 | k < 0
878 -> nl_text `txt` (
879 Str (replicate shift '\\') `txt` (
880 nl_text `txt`
881 lay1 (k + shift) s sl p ))
882
883 _ -> lay1 k s sl p
884 lay _ (Above {}) = error "display lay Above"
885 lay _ (Beside {}) = error "display lay Beside"
886 lay _ NoDoc = error "display lay NoDoc"
887 lay _ (Union {}) = error "display lay Union"
888
889 lay1 !k s !sl p = let !r = k + sl
890 in Str (indent k) `txt` (s `txt` lay2 r p)
891
892 lay2 k _ | k `seq` False = undefined
893 lay2 k (NilAbove p) = nl_text `txt` lay k p
894 lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p
895 lay2 k (Nest _ p) = lay2 k p
896 lay2 _ Empty = end
897 lay2 _ (Above {}) = error "display lay2 Above"
898 lay2 _ (Beside {}) = error "display lay2 Beside"
899 lay2 _ NoDoc = error "display lay2 NoDoc"
900 lay2 _ (Union {}) = error "display lay2 Union"
901 in
902 lay 0 doc
903 }}
904