Restructure code base.
[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 module Text.PrettyPrint.HughesPJ (
26
27 -- * The document type
28 Doc, TextDetails(..),
29
30 -- * Constructing documents
31
32 -- ** Converting values into documents
33 char, text, ptext, sizedText, zeroWidthText,
34 int, integer, float, double, rational,
35
36 -- ** Simple derived documents
37 semi, comma, colon, space, equals,
38 lparen, rparen, lbrack, rbrack, lbrace, rbrace,
39
40 -- ** Wrapping documents in delimiters
41 parens, brackets, braces, quotes, doubleQuotes,
42
43 -- ** Combining documents
44 empty,
45 (<>), (<+>), hcat, hsep,
46 ($$), ($+$), vcat,
47 sep, cat,
48 fsep, fcat,
49 nest,
50 hang, punctuate,
51
52 -- * Predicates on documents
53 isEmpty,
54
55 -- * Utility functions for documents
56 first, reduceDoc,
57
58 -- * Rendering documents
59
60 -- ** Default rendering
61 render,
62
63 -- ** Rendering with a particular style
64 Style(..),
65 style,
66 renderStyle,
67 Mode(..),
68
69 -- ** General rendering
70 fullRender
71
72 ) where
73
74 import Data.Monoid ( Monoid(mempty, mappend) )
75 import Data.String ( IsString(fromString) )
76
77 -- ---------------------------------------------------------------------------
78 -- The Doc calculus
79
80 {-
81 Laws for $$
82 ~~~~~~~~~~~
83 <a1> (x $$ y) $$ z = x $$ (y $$ z)
84 <a2> empty $$ x = x
85 <a3> x $$ empty = x
86
87 ...ditto $+$...
88
89 Laws for <>
90 ~~~~~~~~~~~
91 <b1> (x <> y) <> z = x <> (y <> z)
92 <b2> empty <> x = empty
93 <b3> x <> empty = x
94
95 ...ditto <+>...
96
97 Laws for text
98 ~~~~~~~~~~~~~
99 <t1> text s <> text t = text (s++t)
100 <t2> text "" <> x = x, if x non-empty
101
102 ** because of law n6, t2 only holds if x doesn't
103 ** start with `nest'.
104
105
106 Laws for nest
107 ~~~~~~~~~~~~~
108 <n1> nest 0 x = x
109 <n2> nest k (nest k' x) = nest (k+k') x
110 <n3> nest k (x <> y) = nest k x <> nest k y
111 <n4> nest k (x $$ y) = nest k x $$ nest k y
112 <n5> nest k empty = empty
113 <n6> x <> nest k y = x <> y, if x non-empty
114
115 ** Note the side condition on <n6>! It is this that
116 ** makes it OK for empty to be a left unit for <>.
117
118 Miscellaneous
119 ~~~~~~~~~~~~~
120 <m1> (text s <> x) $$ y = text s <> ((text "" <> x) $$
121 nest (-length s) y)
122
123 <m2> (x $$ y) <> z = x $$ (y <> z)
124 if y non-empty
125
126
127 Laws for list versions
128 ~~~~~~~~~~~~~~~~~~~~~~
129 <l1> sep (ps++[empty]++qs) = sep (ps ++ qs)
130 ...ditto hsep, hcat, vcat, fill...
131
132 <l2> nest k (sep ps) = sep (map (nest k) ps)
133 ...ditto hsep, hcat, vcat, fill...
134
135 Laws for oneLiner
136 ~~~~~~~~~~~~~~~~~
137 <o1> oneLiner (nest k p) = nest k (oneLiner p)
138 <o2> oneLiner (x <> y) = oneLiner x <> oneLiner y
139
140 You might think that the following verion of <m1> would
141 be neater:
142
143 <3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$
144 nest (-length s) y)
145
146 But it doesn't work, for if x=empty, we would have
147
148 text s $$ y = text s <> (empty $$ nest (-length s) y)
149 = text s <> nest (-length s) y
150 -}
151
152 -- ---------------------------------------------------------------------------
153 -- Operator fixity
154
155 infixl 6 <>
156 infixl 6 <+>
157 infixl 5 $$, $+$
158
159 -- ---------------------------------------------------------------------------
160 -- The Doc data type
161
162 -- | The abstract type of documents.
163 -- A Doc represents a *set* of layouts. A Doc with
164 -- no occurrences of Union or NoDoc represents just one layout.
165 data Doc
166 = Empty -- empty
167 | NilAbove Doc -- text "" $$ x
168 | TextBeside !TextDetails {-# UNPACK #-} !Int Doc -- text s <> x
169 | Nest {-# UNPACK #-} !Int Doc -- nest k x
170 | Union Doc Doc -- ul `union` ur
171 | NoDoc -- The empty set of documents
172 | Beside Doc Bool Doc -- True <=> space between
173 | Above Doc Bool Doc -- True <=> never overlap
174
175 {-
176 Here are the invariants:
177
178 1) The argument of NilAbove is never Empty. Therefore
179 a NilAbove occupies at least two lines.
180
181 2) The argument of @TextBeside@ is never @Nest@.
182
183 3) The layouts of the two arguments of @Union@ both flatten to the same
184 string.
185
186 4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
187
188 5) A @NoDoc@ may only appear on the first line of the left argument of an
189 union. Therefore, the right argument of an union can never be equivalent
190 to the empty set (@NoDoc@).
191
192 6) An empty document is always represented by @Empty@. It can't be
193 hidden inside a @Nest@, or a @Union@ of two @Empty@s.
194
195 7) The first line of every layout in the left argument of @Union@ is
196 longer than the first line of any layout in the right argument.
197 (1) ensures that the left argument has a first line. In view of
198 (3), this invariant means that the right argument must have at
199 least two lines.
200
201 Notice the difference between
202 * NoDoc (no documents)
203 * Empty (one empty document; no height and no width)
204 * text "" (a document containing the empty string;
205 one line high, but has no width)
206 -}
207
208
209 -- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside.
210 type RDoc a = Doc
211
212 -- | The TextDetails data type
213 --
214 -- A TextDetails represents a fragment of text that will be
215 -- output at some point.
216 data TextDetails = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment
217 | Str String -- ^ A whole String fragment
218 | PStr String -- ^ Used to represent a Fast String fragment
219 -- but now deprecated and identical to the
220 -- Str constructor.
221
222 -- Combining @Doc@ values
223 instance Monoid Doc where
224 mempty = empty
225 mappend = (<>)
226
227 instance IsString Doc where
228 fromString = text
229
230 instance Show Doc where
231 showsPrec _ doc cont = fullRender (mode style) (lineLength style)
232 (ribbonsPerLine style)
233 txtPrinter cont doc
234
235 -- ---------------------------------------------------------------------------
236 -- Values and Predicates on GDocs and TextDetails
237
238 -- | A document of height and width 1, containing a literal character.
239 char :: Char -> Doc
240 char c = textBeside_ (Chr c) 1 Empty
241
242 -- | A document of height 1 containing a literal string.
243 -- 'text' satisfies the following laws:
244 --
245 -- * @'text' s '<>' 'text' t = 'text' (s'++'t)@
246 --
247 -- * @'text' \"\" '<>' x = x@, if @x@ non-empty
248 --
249 -- The side condition on the last law is necessary because @'text' \"\"@
250 -- has height 1, while 'empty' has no height.
251 text :: String -> Doc
252 text s = case length s of {sl -> textBeside_ (Str s) sl Empty}
253
254 -- | Same as @text@. Used to be used for Bytestrings.
255 ptext :: String -> Doc
256 ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty}
257
258 -- | Some text with any width. (@text s = sizedText (length s) s@)
259 sizedText :: Int -> String -> Doc
260 sizedText l s = textBeside_ (Str s) l Empty
261
262 -- | Some text, but without any width. Use for non-printing text
263 -- such as a HTML or Latex tags
264 zeroWidthText :: String -> Doc
265 zeroWidthText = sizedText 0
266
267 -- | The empty document, with no height and no width.
268 -- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere
269 -- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc.
270 empty :: Doc
271 empty = Empty
272
273 -- | Returns 'True' if the document is empty
274 isEmpty :: Doc -> Bool
275 isEmpty Empty = True
276 isEmpty _ = False
277
278 -- an old version inserted tabs being 8 columns apart in the output.
279 indent :: Int -> String
280 indent !n = replicate n ' '
281 {- TODO: GHC Optimised version
282 -- optimise long indentations using LitString chunks of 8 spaces
283 indent n r | n >=# _ILIT(8) = LStr (sLit " ") (_ILIT(8)) `txt`
284 indent (n -# _ILIT(8)) r
285 | otherwise = Str (spaces n) `txt` r
286 -}
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 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 a
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 a -> RDoc a
448 nilAbove_ p = NilAbove p
449
450 -- Arg of a TextBeside is always an RDoc
451 textBeside_ :: TextDetails -> Int -> RDoc a -> RDoc a
452 textBeside_ s sl p = TextBeside s sl p
453
454 nest_ :: Int -> RDoc a -> RDoc a
455 nest_ k p = Nest k p
456
457 union_ :: RDoc a -> RDoc a -> RDoc a
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 a -> RDoc a
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 a -> Bool -> Int -> RDoc a -> RDoc a
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 a -> RDoc a
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_ (Str (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 a -> RDoc a
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 a -> RDoc a
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 a -> Int -> [Doc] -> RDoc a
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 True here
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 a
666 fill _ [] = empty
667 fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
668
669 fill1 :: Bool -> RDoc a -> 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 True here
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 a
709 -> RDoc a -- 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 Str (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