939ab1d11568127294b53e8160c60dd58442c4dc
[packages/base.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/core/LICENSE)
6 --
7 -- Maintainer : libraries@haskell.org
8 -- Stability : provisional
9 -- Portability : portable
10 --
11 -- $Id: HughesPJ.hs,v 1.1 2001/08/17 12:46:16 simonmar Exp $
12 --
13 -- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators
14 --
15 -- Based on "The Design of a Pretty-printing Library"
16 -- in Advanced Functional Programming,
17 -- Johan Jeuring and Erik Meijer (eds), LNCS 925
18 -- http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps
19 --
20 -- Heavily modified by Simon Peyton Jones, Dec 96
21 --
22 -----------------------------------------------------------------------------
23
24 {-
25 Version 3.0 28 May 1997
26 * Cured massive performance bug. If you write
27
28 foldl <> empty (map (text.show) [1..10000])
29
30 you get quadratic behaviour with V2.0. Why? For just the same
31 reason as you get quadratic behaviour with left-associated (++)
32 chains.
33
34 This is really bad news. One thing a pretty-printer abstraction
35 should certainly guarantee is insensivity to associativity. It
36 matters: suddenly GHC's compilation times went up by a factor of
37 100 when I switched to the new pretty printer.
38
39 I fixed it with a bit of a hack (because I wanted to get GHC back
40 on the road). I added two new constructors to the Doc type, Above
41 and Beside:
42
43 <> = Beside
44 $$ = Above
45
46 Then, where I need to get to a "TextBeside" or "NilAbove" form I
47 "force" the Doc to squeeze out these suspended calls to Beside and
48 Above; but in so doing I re-associate. It's quite simple, but I'm
49 not satisfied that I've done the best possible job. I'll send you
50 the code if you are interested.
51
52 * Added new exports:
53 punctuate, hang
54 int, integer, float, double, rational,
55 lparen, rparen, lbrack, rbrack, lbrace, rbrace,
56
57 * fullRender's type signature has changed. Rather than producing a
58 string it now takes an extra couple of arguments that tells it how
59 to glue fragments of output together:
60
61 fullRender :: Mode
62 -> Int -- Line length
63 -> Float -- Ribbons per line
64 -> (TextDetails -> a -> a) -- What to do with text
65 -> a -- What to do at the end
66 -> Doc
67 -> a -- Result
68
69 The "fragments" are encapsulated in the TextDetails data type:
70
71 data TextDetails = Chr Char
72 | Str String
73 | PStr FAST_STRING
74
75 The Chr and Str constructors are obvious enough. The PStr
76 constructor has a packed string (FAST_STRING) inside it. It's
77 generated by using the new "ptext" export.
78
79 An advantage of this new setup is that you can get the renderer to
80 do output directly (by passing in a function of type (TextDetails
81 -> IO () -> IO ()), rather than producing a string that you then
82 print.
83
84
85 Version 2.0 24 April 1997
86 * Made empty into a left unit for <> as well as a right unit;
87 it is also now true that
88 nest k empty = empty
89 which wasn't true before.
90
91 * Fixed an obscure bug in sep that occassionally gave very wierd behaviour
92
93 * Added $+$
94
95 * Corrected and tidied up the laws and invariants
96
97 ======================================================================
98 Relative to John's original paper, there are the following new features:
99
100 1. There's an empty document, "empty". It's a left and right unit for
101 both <> and $$, and anywhere in the argument list for
102 sep, hcat, hsep, vcat, fcat etc.
103
104 It is Really Useful in practice.
105
106 2. There is a paragraph-fill combinator, fsep, that's much like sep,
107 only it keeps fitting things on one line until itc can't fit any more.
108
109 3. Some random useful extra combinators are provided.
110 <+> puts its arguments beside each other with a space between them,
111 unless either argument is empty in which case it returns the other
112
113
114 hcat is a list version of <>
115 hsep is a list version of <+>
116 vcat is a list version of $$
117
118 sep (separate) is either like hsep or like vcat, depending on what fits
119
120 cat is behaves like sep, but it uses <> for horizontal conposition
121 fcat is behaves like fsep, but it uses <> for horizontal conposition
122
123 These new ones do the obvious things:
124 char, semi, comma, colon, space,
125 parens, brackets, braces,
126 quotes, doubleQuotes
127
128 4. The "above" combinator, $$, now overlaps its two arguments if the
129 last line of the top argument stops before the first line of the
130 second begins.
131
132 For example: text "hi" $$ nest 5 "there"
133 lays out as
134 hi there
135 rather than
136 hi
137 there
138
139 There are two places this is really useful
140
141 a) When making labelled blocks, like this:
142 Left -> code for left
143 Right -> code for right
144 LongLongLongLabel ->
145 code for longlonglonglabel
146 The block is on the same line as the label if the label is
147 short, but on the next line otherwise.
148
149 b) When laying out lists like this:
150 [ first
151 , second
152 , third
153 ]
154 which some people like. But if the list fits on one line
155 you want [first, second, third]. You can't do this with
156 John's original combinators, but it's quite easy with the
157 new $$.
158
159 The combinator $+$ gives the original "never-overlap" behaviour.
160
161 5. Several different renderers are provided:
162 * a standard one
163 * one that uses cut-marks to avoid deeply-nested documents
164 simply piling up in the right-hand margin
165 * one that ignores indentation (fewer chars output; good for machines)
166 * one that ignores indentation and newlines (ditto, only more so)
167
168 6. Numerous implementation tidy-ups
169 Use of unboxed data types to speed up the implementation
170 -}
171
172 module Text.PrettyPrint.HughesPJ (
173 Doc, -- Abstract
174 Mode(..), TextDetails(..),
175
176 empty, isEmpty, nest,
177
178 text, char, ptext,
179 int, integer, float, double, rational,
180 parens, brackets, braces, quotes, doubleQuotes,
181 semi, comma, colon, space, equals,
182 lparen, rparen, lbrack, rbrack, lbrace, rbrace,
183
184 (<>), (<+>), hcat, hsep,
185 ($$), ($+$), vcat,
186 sep, cat,
187 fsep, fcat,
188
189 hang, punctuate,
190
191 -- renderStyle, -- Haskell 1.3 only
192 render, fullRender
193 ) where
194
195
196 import Prelude
197
198 infixl 6 <>
199 infixl 6 <+>
200 infixl 5 $$, $+$
201
202 -- ---------------------------------------------------------------------------
203 -- The interface
204
205 -- The primitive Doc values
206
207 empty :: Doc
208 isEmpty :: Doc -> Bool
209 text :: String -> Doc
210 char :: Char -> Doc
211
212 semi, comma, colon, space, equals :: Doc
213 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
214
215 parens, brackets, braces :: Doc -> Doc
216 quotes, doubleQuotes :: Doc -> Doc
217
218 int :: Int -> Doc
219 integer :: Integer -> Doc
220 float :: Float -> Doc
221 double :: Double -> Doc
222 rational :: Rational -> Doc
223
224
225 -- Combining @Doc@ values
226
227 (<>) :: Doc -> Doc -> Doc -- Beside
228 hcat :: [Doc] -> Doc -- List version of <>
229 (<+>) :: Doc -> Doc -> Doc -- Beside, separated by space
230 hsep :: [Doc] -> Doc -- List version of <+>
231
232 ($$) :: Doc -> Doc -> Doc -- Above; if there is no
233 -- overlap it "dovetails" the two
234 vcat :: [Doc] -> Doc -- List version of $$
235
236 cat :: [Doc] -> Doc -- Either hcat or vcat
237 sep :: [Doc] -> Doc -- Either hsep or vcat
238 fcat :: [Doc] -> Doc -- ``Paragraph fill'' version of cat
239 fsep :: [Doc] -> Doc -- ``Paragraph fill'' version of sep
240
241 nest :: Int -> Doc -> Doc -- Nested
242
243
244 -- GHC-specific ones.
245
246 hang :: Doc -> Int -> Doc -> Doc
247 punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
248
249
250 -- Displaying @Doc@ values.
251
252 instance Show Doc where
253 showsPrec prec doc cont = showDoc doc cont
254
255 render :: Doc -> String -- Uses default style
256 fullRender :: Mode
257 -> Int -- Line length
258 -> Float -- Ribbons per line
259 -> (TextDetails -> a -> a) -- What to do with text
260 -> a -- What to do at the end
261 -> Doc
262 -> a -- Result
263
264 {- When we start using 1.3
265 renderStyle :: Style -> Doc -> String
266 data Style = Style { lineLength :: Int, -- In chars
267 ribbonsPerLine :: Float, -- Ratio of ribbon length to line length
268 mode :: Mode
269 }
270 style :: Style -- The default style
271 style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
272 -}
273
274 data Mode = PageMode -- Normal
275 | ZigZagMode -- With zig-zag cuts
276 | LeftMode -- No indentation, infinitely long lines
277 | OneLineMode -- All on one line
278
279
280 -- ---------------------------------------------------------------------------
281 -- The Doc calculus
282
283 -- The Doc combinators satisfy the following laws:
284
285 {-
286 Laws for $$
287 ~~~~~~~~~~~
288 <a1> (x $$ y) $$ z = x $$ (y $$ z)
289 <a2> empty $$ x = x
290 <a3> x $$ empty = x
291
292 ...ditto $+$...
293
294 Laws for <>
295 ~~~~~~~~~~~
296 <b1> (x <> y) <> z = x <> (y <> z)
297 <b2> empty <> x = empty
298 <b3> x <> empty = x
299
300 ...ditto <+>...
301
302 Laws for text
303 ~~~~~~~~~~~~~
304 <t1> text s <> text t = text (s++t)
305 <t2> text "" <> x = x, if x non-empty
306
307 Laws for nest
308 ~~~~~~~~~~~~~
309 <n1> nest 0 x = x
310 <n2> nest k (nest k' x) = nest (k+k') x
311 <n3> nest k (x <> y) = nest k z <> nest k y
312 <n4> nest k (x $$ y) = nest k x $$ nest k y
313 <n5> nest k empty = empty
314 <n6> x <> nest k y = x <> y, if x non-empty
315
316 ** Note the side condition on <n6>! It is this that
317 ** makes it OK for empty to be a left unit for <>.
318
319 Miscellaneous
320 ~~~~~~~~~~~~~
321 <m1> (text s <> x) $$ y = text s <> ((text "" <> x)) $$
322 nest (-length s) y)
323
324 <m2> (x $$ y) <> z = x $$ (y <> z)
325 if y non-empty
326
327
328 Laws for list versions
329 ~~~~~~~~~~~~~~~~~~~~~~
330 <l1> sep (ps++[empty]++qs) = sep (ps ++ qs)
331 ...ditto hsep, hcat, vcat, fill...
332
333 <l2> nest k (sep ps) = sep (map (nest k) ps)
334 ...ditto hsep, hcat, vcat, fill...
335
336 Laws for oneLiner
337 ~~~~~~~~~~~~~~~~~
338 <o1> oneLiner (nest k p) = nest k (oneLiner p)
339 <o2> oneLiner (x <> y) = oneLiner x <> oneLiner y
340
341 You might think that the following verion of <m1> would
342 be neater:
343
344 <3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$
345 nest (-length s) y)
346
347 But it doesn't work, for if x=empty, we would have
348
349 text s $$ y = text s <> (empty $$ nest (-length s) y)
350 = text s <> nest (-length s) y
351 -}
352
353 -- ---------------------------------------------------------------------------
354 -- Simple derived definitions
355
356 semi = char ';'
357 colon = char ':'
358 comma = char ','
359 space = char ' '
360 equals = char '='
361 lparen = char '('
362 rparen = char ')'
363 lbrack = char '['
364 rbrack = char ']'
365 lbrace = char '{'
366 rbrace = char '}'
367
368 int n = text (show n)
369 integer n = text (show n)
370 float n = text (show n)
371 double n = text (show n)
372 rational n = text (show n)
373 -- SIGBJORN wrote instead:
374 -- rational n = text (show (fromRationalX n))
375
376 quotes p = char '`' <> p <> char '\''
377 doubleQuotes p = char '"' <> p <> char '"'
378 parens p = char '(' <> p <> char ')'
379 brackets p = char '[' <> p <> char ']'
380 braces p = char '{' <> p <> char '}'
381
382
383 hcat = foldr (<>) empty
384 hsep = foldr (<+>) empty
385 vcat = foldr ($$) empty
386
387 hang d1 n d2 = sep [d1, nest n d2]
388
389 punctuate p [] = []
390 punctuate p (d:ds) = go d ds
391 where
392 go d [] = [d]
393 go d (e:es) = (d <> p) : go e es
394
395 -- ---------------------------------------------------------------------------
396 -- The Doc data type
397
398 -- A Doc represents a *set* of layouts. A Doc with
399 -- no occurrences of Union or NoDoc represents just one layout.
400
401 data Doc
402 = Empty -- empty
403 | NilAbove Doc -- text "" $$ x
404 | TextBeside TextDetails !Int Doc -- text s <> x
405 | Nest !Int Doc -- nest k x
406 | Union Doc Doc -- ul `union` ur
407 | NoDoc -- The empty set of documents
408 | Beside Doc Bool Doc -- True <=> space between
409 | Above Doc Bool Doc -- True <=> never overlap
410
411 type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
412
413
414 reduceDoc :: Doc -> RDoc
415 reduceDoc (Beside p g q) = beside p g (reduceDoc q)
416 reduceDoc (Above p g q) = above p g (reduceDoc q)
417 reduceDoc p = p
418
419
420 data TextDetails = Chr Char
421 | Str String
422 | PStr String
423 space_text = Chr ' '
424 nl_text = Chr '\n'
425
426 -- Here are the invariants:
427
428 -- * The argument of NilAbove is never Empty. Therefore
429 -- a NilAbove occupies at least two lines.
430 --
431 -- * The arugment of @TextBeside@ is never @Nest@.
432 --
433 --
434 -- * The layouts of the two arguments of @Union@ both flatten to the same
435 -- string.
436 --
437 -- * The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
438 --
439 -- * The right argument of a union cannot be equivalent to the empty set
440 -- (@NoDoc@). If the left argument of a union is equivalent to the
441 -- empty set (@NoDoc@), then the @NoDoc@ appears in the first line.
442
443 -- * An empty document is always represented by @Empty@. It can't be
444 -- hidden inside a @Nest@, or a @Union@ of two @Empty@s.
445
446 -- * The first line of every layout in the left argument of @Union@ is
447 -- longer than the first line of any layout in the right argument.
448 -- (1) ensures that the left argument has a first line. In view of
449 -- (3), this invariant means that the right argument must have at
450 -- least two lines.
451
452
453 -- Arg of a NilAbove is always an RDoc
454 nilAbove_ p = NilAbove p
455
456 -- Arg of a TextBeside is always an RDoc
457 textBeside_ s sl p = TextBeside s sl p
458
459 -- Arg of Nest is always an RDoc
460 nest_ k p = Nest k p
461
462 -- Args of union are always RDocs
463 union_ p q = Union p q
464
465
466 -- Notice the difference between
467 -- * NoDoc (no documents)
468 -- * Empty (one empty document; no height and no width)
469 -- * text "" (a document containing the empty string;
470 -- one line high, but has no width)
471
472
473 -- ---------------------------------------------------------------------------
474 -- @empty@, @text@, @nest@, @union@
475
476 empty = Empty
477
478 isEmpty Empty = True
479 isEmpty _ = False
480
481 char c = textBeside_ (Chr c) 1 Empty
482 text s = case length s of {sl -> textBeside_ (Str s) sl Empty}
483 ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty}
484
485 nest k p = mkNest k (reduceDoc p) -- Externally callable version
486
487 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
488 mkNest k _ | k `seq` False = undefined
489 mkNest k (Nest k1 p) = mkNest (k + k1) p
490 mkNest k NoDoc = NoDoc
491 mkNest k Empty = Empty
492 mkNest 0 p = p -- Worth a try!
493 mkNest k p = nest_ k p
494
495 -- mkUnion checks for an empty document
496 mkUnion Empty q = Empty
497 mkUnion p q = p `union_` q
498
499 -- ---------------------------------------------------------------------------
500 -- Vertical composition @$$@
501
502 p $$ q = Above p False q
503 p $+$ q = Above p True q
504
505 above :: Doc -> Bool -> RDoc -> RDoc
506 above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
507 above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q)
508 above p g q = aboveNest p g 0 (reduceDoc q)
509
510 aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
511 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
512
513 aboveNest _ _ k _ | k `seq` False = undefined
514 aboveNest NoDoc g k q = NoDoc
515 aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
516 aboveNest p2 g k q
517
518 aboveNest Empty g k q = mkNest k q
519 aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q)
520 -- p can't be Empty, so no need for mkNest
521
522 aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
523 aboveNest (TextBeside s sl p) g k q = k1 `seq` textBeside_ s sl rest
524 where
525 k1 = k - sl
526 rest = case p of
527 Empty -> nilAboveNest g k1 q
528 other -> aboveNest p g k1 q
529
530
531 nilAboveNest :: Bool -> Int -> RDoc -> RDoc
532 -- Specification: text s <> nilaboveNest g k q
533 -- = text s <> (text "" $g$ nest k q)
534
535 nilAboveNest _ k _ | k `seq` False = undefined
536 nilAboveNest g k Empty = Empty -- Here's why the "text s <>" is in the spec!
537 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
538
539 nilAboveNest g k q | (not g) && (k > 0) -- No newline if no overlap
540 = textBeside_ (Str (spaces k)) k q
541 | otherwise -- Put them really above
542 = nilAbove_ (mkNest k q)
543
544 -- ---------------------------------------------------------------------------
545 -- Horizontal composition @<>@
546
547 p <> q = Beside p False q
548 p <+> q = Beside p True q
549
550 beside :: Doc -> Bool -> RDoc -> RDoc
551 -- Specification: beside g p q = p <g> q
552
553 beside NoDoc g q = NoDoc
554 beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q)
555 beside Empty g q = q
556 beside (Nest k p) g q = nest_ k (beside p g q) -- p non-empty
557 beside p@(Beside p1 g1 q1) g2 q2
558 {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2
559 [ && (op1 == <> || op1 == <+>) ] -}
560 | g1 == g2 = beside p1 g1 (beside q1 g2 q2)
561 | otherwise = beside (reduceDoc p) g2 q2
562 beside p@(Above _ _ _) g q = beside (reduceDoc p) g q
563 beside (NilAbove p) g q = nilAbove_ (beside p g q)
564 beside (TextBeside s sl p) g q = textBeside_ s sl rest
565 where
566 rest = case p of
567 Empty -> nilBeside g q
568 other -> beside p g q
569
570
571 nilBeside :: Bool -> RDoc -> RDoc
572 -- Specification: text "" <> nilBeside g p
573 -- = text "" <g> p
574
575 nilBeside g Empty = Empty -- Hence the text "" in the spec
576 nilBeside g (Nest _ p) = nilBeside g p
577 nilBeside g p | g = textBeside_ space_text 1 p
578 | otherwise = p
579
580 -- ---------------------------------------------------------------------------
581 -- Separate, @sep@, Hughes version
582
583 -- Specification: sep ps = oneLiner (hsep ps)
584 -- `union`
585 -- vcat ps
586
587 sep = sepX True -- Separate with spaces
588 cat = sepX False -- Don't
589
590 sepX x [] = empty
591 sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
592
593
594 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
595 -- = oneLiner (x <g> nest k (hsep ys))
596 -- `union` x $$ nest k (vcat ys)
597
598 sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
599 sep1 g _ k ys | k `seq` False = undefined
600 sep1 g NoDoc k ys = NoDoc
601 sep1 g (p `Union` q) k ys = sep1 g p k ys
602 `union_`
603 (aboveNest q False k (reduceDoc (vcat ys)))
604
605 sep1 g Empty k ys = mkNest k (sepX g ys)
606 sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys)
607
608 sep1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
609 sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)
610
611 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
612 -- Called when we have already found some text in the first item
613 -- We have to eat up nests
614
615 sepNB g (Nest _ p) k ys = sepNB g p k ys
616
617 sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))
618 `mkUnion`
619 nilAboveNest False k (reduceDoc (vcat ys))
620 where
621 rest | g = hsep ys
622 | otherwise = hcat ys
623
624 sepNB g p k ys = sep1 g p k ys
625
626 -- ---------------------------------------------------------------------------
627 -- @fill@
628
629 fsep = fill True
630 fcat = fill False
631
632 -- Specification:
633 -- fill [] = empty
634 -- fill [p] = p
635 -- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
636 -- (fill (oneLiner p2 : ps))
637 -- `union`
638 -- p1 $$ fill ps
639
640 fill g [] = empty
641 fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
642
643
644 fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
645 fill1 g _ k ys | k `seq` False = undefined
646 fill1 g NoDoc k ys = NoDoc
647 fill1 g (p `Union` q) k ys = fill1 g p k ys
648 `union_`
649 (aboveNest q False k (fill g ys))
650
651 fill1 g Empty k ys = mkNest k (fill g ys)
652 fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys)
653
654 fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
655 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
656
657 fillNB g _ k ys | k `seq` False = undefined
658 fillNB g (Nest _ p) k ys = fillNB g p k ys
659 fillNB g Empty k [] = Empty
660 fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
661 `mkUnion`
662 nilAboveNest False k (fill g (y:ys))
663 where
664 k1 | g = k - 1
665 | otherwise = k
666
667 fillNB g p k ys = fill1 g p k ys
668
669
670 -- ---------------------------------------------------------------------------
671 -- Selecting the best layout
672
673 best :: Mode
674 -> Int -- Line length
675 -> Int -- Ribbon length
676 -> RDoc
677 -> RDoc -- No unions in here!
678
679 best OneLineMode w r p
680 = get p
681 where
682 get Empty = Empty
683 get NoDoc = NoDoc
684 get (NilAbove p) = nilAbove_ (get p)
685 get (TextBeside s sl p) = textBeside_ s sl (get p)
686 get (Nest k p) = get p -- Elide nest
687 get (p `Union` q) = first (get p) (get q)
688
689 best mode w r p
690 = get w p
691 where
692 get :: Int -- (Remaining) width of line
693 -> Doc -> Doc
694 get w _ | w==0 && False = undefined
695 get w Empty = Empty
696 get w NoDoc = NoDoc
697 get w (NilAbove p) = nilAbove_ (get w p)
698 get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
699 get w (Nest k p) = nest_ k (get (w - k) p)
700 get w (p `Union` q) = nicest w r (get w p) (get w q)
701
702 get1 :: Int -- (Remaining) width of line
703 -> Int -- Amount of first line already eaten up
704 -> Doc -- This is an argument to TextBeside => eat Nests
705 -> Doc -- No unions in here!
706
707 get1 w _ _ | w==0 && False = undefined
708 get1 w sl Empty = Empty
709 get1 w sl NoDoc = NoDoc
710 get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p)
711 get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)
712 get1 w sl (Nest k p) = get1 w sl p
713 get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
714 (get1 w sl q)
715
716 nicest w r p q = nicest1 w r 0 p q
717 nicest1 w r sl p q | fits ((w `minn` r) - sl) p = p
718 | otherwise = q
719
720 fits :: Int -- Space available
721 -> Doc
722 -> Bool -- True if *first line* of Doc fits in space available
723
724 fits n p | n < 0 = False
725 fits n NoDoc = False
726 fits n Empty = True
727 fits n (NilAbove _) = True
728 fits n (TextBeside _ sl p) = fits (n - sl) p
729
730 minn x y | x < y = x
731 | otherwise = y
732
733 -- @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
734 -- @first@ returns its first argument if it is non-empty, otherwise its second.
735
736 first p q | nonEmptySet p = p
737 | otherwise = q
738
739 nonEmptySet NoDoc = False
740 nonEmptySet (p `Union` q) = True
741 nonEmptySet Empty = True
742 nonEmptySet (NilAbove p) = True -- NoDoc always in first line
743 nonEmptySet (TextBeside _ _ p) = nonEmptySet p
744 nonEmptySet (Nest _ p) = nonEmptySet p
745
746 -- @oneLiner@ returns the one-line members of the given set of @Doc@s.
747
748 oneLiner :: Doc -> Doc
749 oneLiner NoDoc = NoDoc
750 oneLiner Empty = Empty
751 oneLiner (NilAbove p) = NoDoc
752 oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
753 oneLiner (Nest k p) = nest_ k (oneLiner p)
754 oneLiner (p `Union` q) = oneLiner p
755
756
757 -- ---------------------------------------------------------------------------
758 -- Displaying the best layout
759
760 {-
761 renderStyle Style{mode, lineLength, ribbonsPerLine} doc
762 = fullRender mode lineLength ribbonsPerLine doc ""
763 -}
764
765 render doc = showDoc doc ""
766 showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc
767
768 string_txt (Chr c) s = c:s
769 string_txt (Str s1) s2 = s1 ++ s2
770 string_txt (PStr s1) s2 = s1 ++ s2
771
772
773 fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc)
774 fullRender LeftMode _ _ txt end doc = easy_display nl_text txt end (reduceDoc doc)
775
776 fullRender mode line_length ribbons_per_line txt end doc
777 = display mode line_length ribbon_length txt end best_doc
778 where
779 best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc)
780
781 hacked_line_length, ribbon_length :: Int
782 ribbon_length = round (fromIntegral line_length / ribbons_per_line)
783 hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length }
784
785 display mode page_width ribbon_width txt end doc
786 = case page_width - ribbon_width of { gap_width ->
787 case gap_width `quot` 2 of { shift ->
788 let
789 lay k _ | k `seq` False = undefined
790 lay k (Nest k1 p) = lay (k + k1) p
791 lay k Empty = end
792
793 lay k (NilAbove p) = nl_text `txt` lay k p
794
795 lay k (TextBeside s sl p)
796 = case mode of
797 ZigZagMode | k >= gap_width
798 -> nl_text `txt` (
799 Str (multi_ch shift '/') `txt` (
800 nl_text `txt` (
801 lay1 (k - shift) s sl p)))
802
803 | k < 0
804 -> nl_text `txt` (
805 Str (multi_ch shift '\\') `txt` (
806 nl_text `txt` (
807 lay1 (k + shift) s sl p )))
808
809 other -> lay1 k s sl p
810
811 lay1 k _ sl _ | k+sl `seq` False = undefined
812 lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p)
813
814 lay2 k _ | k `seq` False = undefined
815 lay2 k (NilAbove p) = nl_text `txt` lay k p
816 lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p)
817 lay2 k (Nest _ p) = lay2 k p
818 lay2 k Empty = end
819 in
820 lay 0 doc
821 }}
822
823 cant_fail = error "easy_display: NoDoc"
824 easy_display nl_text txt end doc
825 = lay doc cant_fail
826 where
827 lay NoDoc no_doc = no_doc
828 lay (Union p q) no_doc = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc
829 lay (Nest k p) no_doc = lay p no_doc
830 lay Empty no_doc = end
831 lay (NilAbove p) no_doc = nl_text `txt` lay p cant_fail -- NoDoc always on first line
832 lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc
833
834 indent n | n >= 8 = '\t' : indent (n - 8)
835 | otherwise = spaces n
836
837 multi_ch 0 ch = ""
838 multi_ch n ch = ch : multi_ch (n - 1) ch
839
840 spaces 0 = ""
841 spaces n = ' ' : spaces (n - 1)
842