9f40d15d1eed979526aca95df40116432245cf04
[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 -- an old version inserted tabs being 8 columns apart in the output.
283 indent :: Int -> TextDetails
284 indent n | n >= 8 = Str " " `txt` indent (n - 8)
285 | otherwise = Str $ replicate n ' '
286
287 {-
288 Q: What is the reason for negative indentation (i.e. argument to indent
289 is < 0) ?
290
291 A:
292 This indicates an error in the library client's code.
293 If we compose a <> b, and the first line of b is more indented than some
294 other lines of b, the law <n6> (<> eats nests) may cause the pretty
295 printer to produce an invalid layout:
296
297 doc |0123345
298 ------------------
299 d1 |a...|
300 d2 |...b|
301 |c...|
302
303 d1<>d2 |ab..|
304 c|....|
305
306 Consider a <> b, let `s' be the length of the last line of `a', `k' the
307 indentation of the first line of b, and `k0' the indentation of the
308 left-most line b_i of b.
309
310 The produced layout will have negative indentation if `k - k0 > s', as
311 the first line of b will be put on the (s+1)th column, effectively
312 translating b horizontally by (k-s). Now if the i^th line of b has an
313 indentation k0 < (k-s), it is translated out-of-page, causing
314 `negative indentation'.
315 -}
316
317
318 semi :: Doc -- ^ A ';' character
319 comma :: Doc -- ^ A ',' character
320 colon :: Doc -- ^ A ':' character
321 space :: Doc -- ^ A space character
322 equals :: Doc -- ^ A '=' character
323 lparen :: Doc -- ^ A '(' character
324 rparen :: Doc -- ^ A ')' character
325 lbrack :: Doc -- ^ A '[' character
326 rbrack :: Doc -- ^ A ']' character
327 lbrace :: Doc -- ^ A '{' character
328 rbrace :: Doc -- ^ A '}' character
329 semi = char ';'
330 comma = char ','
331 colon = char ':'
332 space = char ' '
333 equals = char '='
334 lparen = char '('
335 rparen = char ')'
336 lbrack = char '['
337 rbrack = char ']'
338 lbrace = char '{'
339 rbrace = char '}'
340
341 space_text, nl_text :: TextDetails
342 space_text = Chr ' '
343 nl_text = Chr '\n'
344
345 int :: Int -> Doc -- ^ @int n = text (show n)@
346 integer :: Integer -> Doc -- ^ @integer n = text (show n)@
347 float :: Float -> Doc -- ^ @float n = text (show n)@
348 double :: Double -> Doc -- ^ @double n = text (show n)@
349 rational :: Rational -> Doc -- ^ @rational n = text (show n)@
350 int n = text (show n)
351 integer n = text (show n)
352 float n = text (show n)
353 double n = text (show n)
354 rational n = text (show n)
355
356 parens :: Doc -> Doc -- ^ Wrap document in @(...)@
357 brackets :: Doc -> Doc -- ^ Wrap document in @[...]@
358 braces :: Doc -> Doc -- ^ Wrap document in @{...}@
359 quotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@
360 doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@
361 quotes p = char '\'' <> p <> char '\''
362 doubleQuotes p = char '"' <> p <> char '"'
363 parens p = char '(' <> p <> char ')'
364 brackets p = char '[' <> p <> char ']'
365 braces p = char '{' <> p <> char '}'
366
367
368 -- ---------------------------------------------------------------------------
369 -- Structural operations on GDocs
370
371 -- | Perform some simplification of a built up @GDoc@.
372 reduceDoc :: Doc -> RDoc
373 reduceDoc (Beside p g q) = beside p g (reduceDoc q)
374 reduceDoc (Above p g q) = above p g (reduceDoc q)
375 reduceDoc p = p
376
377 -- | List version of '<>'.
378 hcat :: [Doc] -> Doc
379 hcat = reduceAB . foldr (beside_' False) empty
380
381 -- | List version of '<+>'.
382 hsep :: [Doc] -> Doc
383 hsep = reduceAB . foldr (beside_' True) empty
384
385 -- | List version of '$$'.
386 vcat :: [Doc] -> Doc
387 vcat = reduceAB . foldr (above_' False) empty
388
389 -- | Nest (or indent) a document by a given number of positions
390 -- (which may also be negative). 'nest' satisfies the laws:
391 --
392 -- * @'nest' 0 x = x@
393 --
394 -- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@
395 --
396 -- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@
397 --
398 -- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@
399 --
400 -- * @'nest' k 'empty' = 'empty'@
401 --
402 -- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty
403 --
404 -- The side condition on the last law is needed because
405 -- 'empty' is a left identity for '<>'.
406 nest :: Int -> Doc -> Doc
407 nest k p = mkNest k (reduceDoc p)
408
409 -- | @hang d1 n d2 = sep [d1, nest n d2]@
410 hang :: Doc -> Int -> Doc -> Doc
411 hang d1 n d2 = sep [d1, nest n d2]
412
413 -- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@
414 punctuate :: Doc -> [Doc] -> [Doc]
415 punctuate _ [] = []
416 punctuate p (x:xs) = go x xs
417 where go y [] = [y]
418 go y (z:zs) = (y <> p) : go z zs
419
420 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
421 mkNest :: Int -> Doc -> Doc
422 mkNest k _ | k `seq` False = undefined
423 mkNest k (Nest k1 p) = mkNest (k + k1) p
424 mkNest _ NoDoc = NoDoc
425 mkNest _ Empty = Empty
426 mkNest 0 p = p
427 mkNest k p = nest_ k p
428
429 -- mkUnion checks for an empty document
430 mkUnion :: Doc -> Doc -> Doc
431 mkUnion Empty _ = Empty
432 mkUnion p q = p `union_` q
433
434 beside_' :: Bool -> Doc -> Doc -> Doc
435 beside_' _ p Empty = p
436 beside_' g p q = Beside p g q
437
438 above_' :: Bool -> Doc -> Doc -> Doc
439 above_' _ p Empty = p
440 above_' g p q = Above p g q
441
442 reduceAB :: Doc -> Doc
443 reduceAB (Above Empty _ q) = q
444 reduceAB (Beside Empty _ q) = q
445 reduceAB doc = doc
446
447 nilAbove_ :: RDoc -> RDoc
448 nilAbove_ p = NilAbove p
449
450 -- Arg of a TextBeside is always an RDoc
451 textBeside_ :: TextDetails -> Int -> RDoc -> RDoc
452 textBeside_ s sl p = TextBeside s sl p
453
454 nest_ :: Int -> RDoc -> RDoc
455 nest_ k p = Nest k p
456
457 union_ :: RDoc -> RDoc -> RDoc
458 union_ p q = Union p q
459
460
461 -- ---------------------------------------------------------------------------
462 -- Vertical composition @$$@
463
464 -- | Above, except that if the last line of the first argument stops
465 -- at least one position before the first line of the second begins,
466 -- these two lines are overlapped. For example:
467 --
468 -- > text "hi" $$ nest 5 (text "there")
469 --
470 -- lays out as
471 --
472 -- > hi there
473 --
474 -- rather than
475 --
476 -- > hi
477 -- > there
478 --
479 -- '$$' is associative, with identity 'empty', and also satisfies
480 --
481 -- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty.
482 --
483 ($$) :: Doc -> Doc -> Doc
484 p $$ q = above_ p False q
485
486 -- | Above, with no overlapping.
487 -- '$+$' is associative, with identity 'empty'.
488 ($+$) :: Doc -> Doc -> Doc
489 p $+$ q = above_ p True q
490
491 above_ :: Doc -> Bool -> Doc -> Doc
492 above_ p _ Empty = p
493 above_ Empty _ q = q
494 above_ p g q = Above p g q
495
496 above :: Doc -> Bool -> RDoc -> RDoc
497 above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
498 above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q)
499 above p g q = aboveNest p g 0 (reduceDoc q)
500
501 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
502 aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
503 aboveNest _ _ k _ | k `seq` False = undefined
504 aboveNest NoDoc _ _ _ = NoDoc
505 aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
506 aboveNest p2 g k q
507
508 aboveNest Empty _ k q = mkNest k q
509 aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q)
510 -- p can't be Empty, so no need for mkNest
511
512 aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
513 aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
514 where
515 !k1 = k - sl
516 rest = case p of
517 Empty -> nilAboveNest g k1 q
518 _ -> aboveNest p g k1 q
519 aboveNest (Above {}) _ _ _ = error "aboveNest Above"
520 aboveNest (Beside {}) _ _ _ = error "aboveNest Beside"
521
522 -- Specification: text s <> nilaboveNest g k q
523 -- = text s <> (text "" $g$ nest k q)
524 nilAboveNest :: Bool -> Int -> RDoc -> RDoc
525 nilAboveNest _ k _ | k `seq` False = undefined
526 nilAboveNest _ _ Empty = Empty
527 -- Here's why the "text s <>" is in the spec!
528 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
529 nilAboveNest g k q | not g && k > 0 -- No newline if no overlap
530 = textBeside_ (indent k) k q
531 | otherwise -- Put them really above
532 = nilAbove_ (mkNest k q)
533
534
535 -- ---------------------------------------------------------------------------
536 -- Horizontal composition @<>@
537
538 -- We intentionally avoid Data.Monoid.(<>) here due to interactions of
539 -- Data.Monoid.(<>) and (<+>). See
540 -- http://www.haskell.org/pipermail/libraries/2011-November/017066.html
541
542 -- | Beside.
543 -- '<>' is associative, with identity 'empty'.
544 (<>) :: Doc -> Doc -> Doc
545 p <> q = beside_ p False q
546
547 -- | Beside, separated by space, unless one of the arguments is 'empty'.
548 -- '<+>' is associative, with identity 'empty'.
549 (<+>) :: Doc -> Doc -> Doc
550 p <+> q = beside_ p True q
551
552 beside_ :: Doc -> Bool -> Doc -> Doc
553 beside_ p _ Empty = p
554 beside_ Empty _ q = q
555 beside_ p g q = Beside p g q
556
557 -- Specification: beside g p q = p <g> q
558 beside :: Doc -> Bool -> RDoc -> RDoc
559 beside NoDoc _ _ = NoDoc
560 beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q
561 beside Empty _ q = q
562 beside (Nest k p) g q = nest_ k $! beside p g q
563 beside p@(Beside p1 g1 q1) g2 q2
564 | g1 == g2 = beside p1 g1 $! beside q1 g2 q2
565 | otherwise = beside (reduceDoc p) g2 q2
566 beside p@(Above _ _ _) g q = let !d = reduceDoc p in beside d g q
567 beside (NilAbove p) g q = nilAbove_ $! beside p g q
568 beside (TextBeside s sl p) g q = textBeside_ s sl $! rest
569 where
570 rest = case p of
571 Empty -> nilBeside g q
572 _ -> beside p g q
573
574 -- Specification: text "" <> nilBeside g p
575 -- = text "" <g> p
576 nilBeside :: Bool -> RDoc -> RDoc
577 nilBeside _ Empty = Empty -- Hence the text "" in the spec
578 nilBeside g (Nest _ p) = nilBeside g p
579 nilBeside g p | g = textBeside_ space_text 1 p
580 | otherwise = p
581
582
583 -- ---------------------------------------------------------------------------
584 -- Separate, @sep@
585
586 -- Specification: sep ps = oneLiner (hsep ps)
587 -- `union`
588 -- vcat ps
589
590 -- | Either 'hsep' or 'vcat'.
591 sep :: [Doc] -> Doc
592 sep = sepX True -- Separate with spaces
593
594 -- | Either 'hcat' or 'vcat'.
595 cat :: [Doc] -> Doc
596 cat = sepX False -- Don't
597
598 sepX :: Bool -> [Doc] -> Doc
599 sepX _ [] = empty
600 sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
601
602
603 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
604 -- = oneLiner (x <g> nest k (hsep ys))
605 -- `union` x $$ nest k (vcat ys)
606 sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
607 sep1 _ _ k _ | k `seq` False = undefined
608 sep1 _ NoDoc _ _ = NoDoc
609 sep1 g (p `Union` q) k ys = sep1 g p k ys `union_`
610 aboveNest q False k (reduceDoc (vcat ys))
611
612 sep1 g Empty k ys = mkNest k (sepX g ys)
613 sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys)
614
615 sep1 _ (NilAbove p) k ys = nilAbove_
616 (aboveNest p False k (reduceDoc (vcat ys)))
617 sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)
618 sep1 _ (Above {}) _ _ = error "sep1 Above"
619 sep1 _ (Beside {}) _ _ = error "sep1 Beside"
620
621 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
622 -- Called when we have already found some text in the first item
623 -- We have to eat up nests
624 sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc
625 sepNB g (Nest _ p) k ys
626 = sepNB g p k ys -- Never triggered, because of invariant (2)
627 sepNB g Empty k ys
628 = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion`
629 -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...)
630 nilAboveNest False k (reduceDoc (vcat ys))
631 where
632 rest | g = hsep ys
633 | otherwise = hcat ys
634 sepNB g p k ys
635 = sep1 g p k ys
636
637
638 -- ---------------------------------------------------------------------------
639 -- @fill@
640
641 -- | \"Paragraph fill\" version of 'cat'.
642 fcat :: [Doc] -> Doc
643 fcat = fill False
644
645 -- | \"Paragraph fill\" version of 'sep'.
646 fsep :: [Doc] -> Doc
647 fsep = fill True
648
649 -- Specification:
650 --
651 -- fill g docs = fillIndent 0 docs
652 --
653 -- fillIndent k [] = []
654 -- fillIndent k [p] = p
655 -- fillIndent k (p1:p2:ps) =
656 -- oneLiner p1 <g> fillIndent (k + length p1 + g ? 1 : 0)
657 -- (remove_nests (oneLiner p2) : ps)
658 -- `Union`
659 -- (p1 $*$ nest (-k) (fillIndent 0 ps))
660 --
661 -- $*$ is defined for layouts (not Docs) as
662 -- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2
663 -- | otherwise = layout1 $+$ layout2
664
665 fill :: Bool -> [Doc] -> RDoc
666 fill _ [] = empty
667 fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
668
669 fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
670 fill1 _ _ k _ | k `seq` False = undefined
671 fill1 _ NoDoc _ _ = NoDoc
672 fill1 g (p `Union` q) k ys = fill1 g p k ys `union_`
673 aboveNest q False k (fill g ys)
674 fill1 g Empty k ys = mkNest k (fill g ys)
675 fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys)
676 fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
677 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
678 fill1 _ (Above {}) _ _ = error "fill1 Above"
679 fill1 _ (Beside {}) _ _ = error "fill1 Beside"
680
681 fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc
682 fillNB _ _ k _ | k `seq` False = undefined
683 fillNB g (Nest _ p) k ys = fillNB g p k ys
684 -- Never triggered, because of invariant (2)
685 fillNB _ Empty _ [] = Empty
686 fillNB g Empty k (Empty:ys) = fillNB g Empty k ys
687 fillNB g Empty k (y:ys) = fillNBE g k y ys
688 fillNB g p k ys = fill1 g p k ys
689
690
691 fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc
692 fillNBE g k y ys
693 = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys)
694 -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...)
695 `mkUnion` nilAboveNest False k (fill g (y:ys))
696 where k' = if g then k - 1 else k
697
698 elideNest :: Doc -> Doc
699 elideNest (Nest _ d) = d
700 elideNest d = d
701
702
703 -- ---------------------------------------------------------------------------
704 -- Selecting the best layout
705
706 best :: Int -- Line length
707 -> Int -- Ribbon length
708 -> RDoc
709 -> RDoc -- No unions in here!
710 best w0 r p0
711 = get w0 p0
712 where
713 get w _ | w == 0 && False = undefined
714 get _ Empty = Empty
715 get _ NoDoc = NoDoc
716 get w (NilAbove p) = nilAbove_ (get w p)
717 get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
718 get w (Nest k p) = nest_ k (get (w - k) p)
719 get w (p `Union` q) = nicest w r (get w p) (get w q)
720 get _ (Above {}) = error "best get Above"
721 get _ (Beside {}) = error "best get Beside"
722
723 get1 w _ _ | w == 0 && False = undefined
724 get1 _ _ Empty = Empty
725 get1 _ _ NoDoc = NoDoc
726 get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p)
727 get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)
728 get1 w sl (Nest _ p) = get1 w sl p
729 get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
730 (get1 w sl q)
731 get1 _ _ (Above {}) = error "best get1 Above"
732 get1 _ _ (Beside {}) = error "best get1 Beside"
733
734 nicest :: Int -> Int -> Doc -> Doc -> Doc
735 nicest !w !r p q = nicest1 w r 0 p q
736
737 nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc
738 nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p
739 | otherwise = q
740
741 fits :: Int -- Space available
742 -> Doc
743 -> Bool -- True if *first line* of Doc fits in space available
744 fits n _ | n < 0 = False
745 fits _ NoDoc = False
746 fits _ Empty = True
747 fits _ (NilAbove _) = True
748 fits n (TextBeside _ sl p) = fits (n - sl) p
749 fits _ (Above {}) = error "fits Above"
750 fits _ (Beside {}) = error "fits Beside"
751 fits _ (Union {}) = error "fits Union"
752 fits _ (Nest {}) = error "fits Nest"
753
754 -- | @first@ returns its first argument if it is non-empty, otherwise its second.
755 first :: Doc -> Doc -> Doc
756 first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused
757 | otherwise = q
758
759 nonEmptySet :: Doc -> Bool
760 nonEmptySet NoDoc = False
761 nonEmptySet (_ `Union` _) = True
762 nonEmptySet Empty = True
763 nonEmptySet (NilAbove _) = True
764 nonEmptySet (TextBeside _ _ p) = nonEmptySet p
765 nonEmptySet (Nest _ p) = nonEmptySet p
766 nonEmptySet (Above {}) = error "nonEmptySet Above"
767 nonEmptySet (Beside {}) = error "nonEmptySet Beside"
768
769 -- @oneLiner@ returns the one-line members of the given set of @GDoc@s.
770 oneLiner :: Doc -> Doc
771 oneLiner NoDoc = NoDoc
772 oneLiner Empty = Empty
773 oneLiner (NilAbove _) = NoDoc
774 oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
775 oneLiner (Nest k p) = nest_ k (oneLiner p)
776 oneLiner (p `Union` _) = oneLiner p
777 oneLiner (Above {}) = error "oneLiner Above"
778 oneLiner (Beside {}) = error "oneLiner Beside"
779
780
781 -- ---------------------------------------------------------------------------
782 -- Rendering
783
784 -- | A rendering style.
785 data Style
786 = Style { mode :: Mode -- ^ The rendering mode
787 , lineLength :: Int -- ^ Length of line, in chars
788 , ribbonsPerLine :: Float -- ^ Ratio of ribbon length to line length
789 }
790
791 -- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@).
792 style :: Style
793 style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode }
794
795 -- | Rendering mode.
796 data Mode = PageMode -- ^ Normal
797 | ZigZagMode -- ^ With zig-zag cuts
798 | LeftMode -- ^ No indentation, infinitely long lines
799 | OneLineMode -- ^ All on one line
800
801 -- | Render the @Doc@ to a String using the default @Style@.
802 render :: Doc -> String
803 render doc = fullRender (mode style) (lineLength style) (ribbonsPerLine style)
804 txtPrinter "" doc
805
806 -- | Render the @Doc@ to a String using the given @Style@.
807 renderStyle :: Style -> Doc -> String
808 renderStyle s doc = fullRender (mode s) (lineLength s) (ribbonsPerLine s)
809 txtPrinter "" doc
810
811 -- | Default TextDetails printer
812 txtPrinter :: TextDetails -> String -> String
813 txtPrinter (Chr c) s = c:s
814 txtPrinter (Str s1) s2 = s1 ++ s2
815 txtPrinter (PStr s1) s2 = s1 ++ s2
816
817 -- | The general rendering interface.
818 fullRender :: Mode -- ^ Rendering mode
819 -> Int -- ^ Line length
820 -> Float -- ^ Ribbons per line
821 -> (TextDetails -> a -> a) -- ^ What to do with text
822 -> a -- ^ What to do at the end
823 -> Doc -- ^ The document
824 -> a -- ^ Result
825 fullRender OneLineMode _ _ txt end doc
826 = easy_display space_text (\_ y -> y) txt end (reduceDoc doc)
827 fullRender LeftMode _ _ txt end doc
828 = easy_display nl_text first txt end (reduceDoc doc)
829
830 fullRender m lineLen ribbons txt rest doc
831 = display m lineLen ribbonLen txt rest doc'
832 where
833 doc' = best bestLineLen ribbonLen (reduceDoc doc)
834
835 bestLineLen, ribbonLen :: Int
836 ribbonLen = round (fromIntegral lineLen / ribbons)
837 bestLineLen = case m of
838 ZigZagMode -> maxBound
839 _ -> lineLen
840
841 easy_display :: TextDetails
842 -> (Doc -> Doc -> Doc)
843 -> (TextDetails -> a -> a)
844 -> a
845 -> Doc
846 -> a
847 easy_display nl_space_text choose txt end doc
848 = lay doc
849 where
850 lay NoDoc = error "easy_display: NoDoc"
851 lay (Union p q) = lay (choose p q)
852 lay (Nest _ p) = lay p
853 lay Empty = end
854 lay (NilAbove p) = nl_space_text `txt` lay p
855 lay (TextBeside s _ p) = s `txt` lay p
856 lay (Above {}) = error "easy_display Above"
857 lay (Beside {}) = error "easy_display Beside"
858
859 display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a
860 display m !page_width !ribbon_width txt end doc
861 = case page_width - ribbon_width of { gap_width ->
862 case gap_width `quot` 2 of { shift ->
863 let
864 lay k _ | k `seq` False = undefined
865 lay k (Nest k1 p) = lay (k + k1) p
866 lay _ Empty = end
867 lay k (NilAbove p) = nl_text `txt` lay k p
868 lay k (TextBeside s sl p)
869 = case m of
870 ZigZagMode | k >= gap_width
871 -> nl_text `txt` (
872 Str (replicate shift '/') `txt` (
873 nl_text `txt`
874 lay1 (k - shift) s sl p ))
875
876 | k < 0
877 -> nl_text `txt` (
878 Str (replicate shift '\\') `txt` (
879 nl_text `txt`
880 lay1 (k + shift) s sl p ))
881
882 _ -> lay1 k s sl p
883 lay _ (Above {}) = error "display lay Above"
884 lay _ (Beside {}) = error "display lay Beside"
885 lay _ NoDoc = error "display lay NoDoc"
886 lay _ (Union {}) = error "display lay Union"
887
888 lay1 !k s !sl p = let !r = k + sl
889 in indent k `txt` (s `txt` lay2 r p)
890
891 lay2 k _ | k `seq` False = undefined
892 lay2 k (NilAbove p) = nl_text `txt` lay k p
893 lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p
894 lay2 k (Nest _ p) = lay2 k p
895 lay2 _ Empty = end
896 lay2 _ (Above {}) = error "display lay2 Above"
897 lay2 _ (Beside {}) = error "display lay2 Beside"
898 lay2 _ NoDoc = error "display lay2 NoDoc"
899 lay2 _ (Union {}) = error "display lay2 Union"
900 in
901 lay 0 doc
902 }}
903