1 *********************************************************************************
3 * John Hughes's and Simon Peyton Jones's Pretty Printer Combinators *
5 * based on "The Design of a Pretty-printing Library" *
6 * in Advanced Functional Programming, *
7 * Johan Jeuring and Erik Meijer (eds), LNCS 925 *
8 * http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps *
10 * Heavily modified by Simon Peyton Jones, Dec 96 *
12 *********************************************************************************
14 Version 3.0 28 May 1997
15 * Cured massive performance bug. If you write
17 foldl <> empty (map (text.show) [1..10000])
19 you get quadratic behaviour with V2.0. Why? For just the same reason as you get
20 quadratic behaviour with left-associated (++) chains.
22 This is really bad news. One thing a pretty-printer abstraction should
23 certainly guarantee is insensivity to associativity. It matters: suddenly
24 GHC's compilation times went up by a factor of 100 when I switched to the
27 I fixed it with a bit of a hack (because I wanted to get GHC back on the
28 road). I added two new constructors to the Doc type, Above and Beside:
33 Then, where I need to get to a "TextBeside" or "NilAbove" form I "force"
34 the Doc to squeeze out these suspended calls to Beside and Above; but in so
35 doing I re-associate. It's quite simple, but I'm not satisfied that I've done
36 the best possible job. I'll send you the code if you are interested.
40 int, integer, float, double, rational,
41 lparen, rparen, lbrack, rbrack, lbrace, rbrace,
43 * fullRender's type signature has changed. Rather than producing a string it
44 now takes an extra couple of arguments that tells it how to glue fragments
49 -> Float -- Ribbons per line
50 -> (TextDetails -> a -> a) -- What to do with text
51 -> a -- What to do at the end
55 The "fragments" are encapsulated in the TextDetails data type:
56 data TextDetails = Chr Char
60 The Chr and Str constructors are obvious enough. The PStr constructor has a packed
61 string (FastString) inside it. It's generated by using the new "ptext" export.
63 An advantage of this new setup is that you can get the renderer to do output
64 directly (by passing in a function of type (TextDetails -> IO () -> IO ()),
65 rather than producing a string that you then print.
68 Version 2.0 24 April 1997
69 * Made empty into a left unit for <> as well as a right unit;
70 it is also now true that
72 which wasn't true before.
74 * Fixed an obscure bug in sep that occassionally gave very wierd behaviour
78 * Corrected and tidied up the laws and invariants
80 ======================================================================
81 Relative to John's original paper, there are the following new features:
83 1. There's an empty document, "empty". It's a left and right unit for
84 both <> and $$, and anywhere in the argument list for
85 sep, hcat, hsep, vcat, fcat etc.
87 It is Really Useful in practice.
89 2. There is a paragraph-fill combinator, fsep, that's much like sep,
90 only it keeps fitting things on one line until it can't fit any more.
92 3. Some random useful extra combinators are provided.
93 <+> puts its arguments beside each other with a space between them,
94 unless either argument is empty in which case it returns the other
97 hcat is a list version of <>
98 hsep is a list version of <+>
99 vcat is a list version of $$
101 sep (separate) is either like hsep or like vcat, depending on what fits
103 cat is behaves like sep, but it uses <> for horizontal conposition
104 fcat is behaves like fsep, but it uses <> for horizontal conposition
106 These new ones do the obvious things:
107 char, semi, comma, colon, space,
108 parens, brackets, braces,
111 4. The "above" combinator, $$, now overlaps its two arguments if the
112 last line of the top argument stops before the first line of the second begins.
113 For example: text "hi" $$ nest 5 "there"
120 There are two places this is really useful
122 a) When making labelled blocks, like this:
123 Left -> code for left
124 Right -> code for right
126 code for longlonglonglabel
127 The block is on the same line as the label if the label is
128 short, but on the next line otherwise.
130 b) When laying out lists like this:
135 which some people like. But if the list fits on one line
136 you want [first, second, third]. You can't do this with
137 John's original combinators, but it's quite easy with the
140 The combinator $+$ gives the original "never-overlap" behaviour.
142 5. Several different renderers are provided:
144 * one that uses cut-marks to avoid deeply-nested documents
145 simply piling up in the right-hand margin
146 * one that ignores indentation (fewer chars output; good for machines)
147 * one that ignores indentation and newlines (ditto, only more so)
149 6. Numerous implementation tidy-ups
150 Use of unboxed data types to speed up the implementation
157 Mode(..), TextDetails(..),
159 empty, isEmpty, nest,
161 text, char, ftext, ptext,
162 int, integer, float, double, rational,
163 parens, brackets, braces, quotes, doubleQuotes,
164 semi, comma, colon, space, equals,
165 lparen, rparen, lbrack, rbrack, lbrace, rbrace, cparen,
167 (<>), (<+>), hcat, hsep,
174 -- renderStyle, -- Haskell 1.3 only
175 render, fullRender, printDoc, showDocWith
178 #include "HsVersions.h"
185 import Numeric (fromRat)
187 --import Foreign.Ptr (castPtr)
189 #if defined(__GLASGOW_HASKELL__)
191 import GHC.Base ( unpackCString# )
192 import GHC.Exts ( Int# )
193 import GHC.Ptr ( Ptr(..) )
196 -- Don't import Util( assertPanic ) because it makes a loop in the module structure
206 -- Disable ASSERT checks; they are expensive!
207 #define LOCAL_ASSERT(x)
212 *********************************************************
214 \subsection{The interface}
216 *********************************************************
218 The primitive @Doc@ values
222 isEmpty :: Doc -> Bool
223 text :: String -> Doc
226 semi, comma, colon, space, equals :: Doc
227 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
229 parens, brackets, braces :: Doc -> Doc
230 quotes, doubleQuotes :: Doc -> Doc
233 integer :: Integer -> Doc
234 float :: Float -> Doc
235 double :: Double -> Doc
236 rational :: Rational -> Doc
239 Combining @Doc@ values
242 (<>) :: Doc -> Doc -> Doc -- Beside
243 hcat :: [Doc] -> Doc -- List version of <>
244 (<+>) :: Doc -> Doc -> Doc -- Beside, separated by space
245 hsep :: [Doc] -> Doc -- List version of <+>
247 ($$) :: Doc -> Doc -> Doc -- Above; if there is no
248 -- overlap it "dovetails" the two
249 vcat :: [Doc] -> Doc -- List version of $$
251 cat :: [Doc] -> Doc -- Either hcat or vcat
252 sep :: [Doc] -> Doc -- Either hsep or vcat
253 fcat :: [Doc] -> Doc -- ``Paragraph fill'' version of cat
254 fsep :: [Doc] -> Doc -- ``Paragraph fill'' version of sep
256 nest :: Int -> Doc -> Doc -- Nested
262 hang :: Doc -> Int -> Doc -> Doc
263 punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
266 Displaying @Doc@ values.
269 instance Show Doc where
270 showsPrec _ doc cont = showDoc doc cont
272 render :: Doc -> String -- Uses default style
274 -> Int -- Line length
275 -> Float -- Ribbons per line
276 -> (TextDetails -> a -> a) -- What to do with text
277 -> a -- What to do at the end
281 {- When we start using 1.3
282 renderStyle :: Style -> Doc -> String
283 data Style = Style { lineLength :: Int, -- In chars
284 ribbonsPerLine :: Float, -- Ratio of ribbon length to line length
287 style :: Style -- The default style
288 style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
291 data Mode = PageMode -- Normal
292 | ZigZagMode -- With zig-zag cuts
293 | LeftMode -- No indentation, infinitely long lines
294 | OneLineMode -- All on one line
299 *********************************************************
301 \subsection{The @Doc@ calculus}
303 *********************************************************
305 The @Doc@ combinators satisfy the following laws:
309 <a1> (x $$ y) $$ z = x $$ (y $$ z)
317 <b1> (x <> y) <> z = x <> (y <> z)
318 <b2> empty <> x = empty
325 <t1> text s <> text t = text (s++t)
326 <t2> text "" <> x = x, if x non-empty
331 <n2> nest k (nest k' x) = nest (k+k') x
332 <n3> nest k (x <> y) = nest k z <> nest k y
333 <n4> nest k (x $$ y) = nest k x $$ nest k y
334 <n5> nest k empty = empty
335 <n6> x <> nest k y = x <> y, if x non-empty
337 ** Note the side condition on <n6>! It is this that
338 ** makes it OK for empty to be a left unit for <>.
342 <m1> (text s <> x) $$ y = text s <> ((text "" <> x)) $$
345 <m2> (x $$ y) <> z = x $$ (y <> z)
349 Laws for list versions
350 ~~~~~~~~~~~~~~~~~~~~~~
351 <l1> sep (ps++[empty]++qs) = sep (ps ++ qs)
352 ...ditto hsep, hcat, vcat, fill...
354 <l2> nest k (sep ps) = sep (map (nest k) ps)
355 ...ditto hsep, hcat, vcat, fill...
359 <o1> oneLiner (nest k p) = nest k (oneLiner p)
360 <o2> oneLiner (x <> y) = oneLiner x <> oneLiner y
364 You might think that the following verion of <m1> would
367 <3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$
370 But it doesn't work, for if x=empty, we would have
372 text s $$ y = text s <> (empty $$ nest (-length s) y)
373 = text s <> nest (-length s) y
378 *********************************************************
380 \subsection{Simple derived definitions}
382 *********************************************************
397 int n = text (show n)
398 integer n = text (show n)
399 float n = text (show n)
400 double n = text (show n)
401 rational n = text (show (fromRat n :: Double))
402 --rational n = text (show (fromRationalX n)) -- _showRational 30 n)
404 quotes p = char '`' <> p <> char '\''
405 doubleQuotes p = char '"' <> p <> char '"'
406 parens p = char '(' <> p <> char ')'
407 brackets p = char '[' <> p <> char ']'
408 braces p = char '{' <> p <> char '}'
410 cparen :: Bool -> Doc -> Doc
414 hcat = foldr (<>) empty
415 hsep = foldr (<+>) empty
416 vcat = foldr ($$) empty
418 hang d1 n d2 = sep [d1, nest n d2]
421 punctuate p (d:ds) = go d ds
424 go d (e:es) = (d <> p) : go e es
428 *********************************************************
430 \subsection{The @Doc@ data type}
432 *********************************************************
434 A @Doc@ represents a {\em set} of layouts. A @Doc@ with
435 no occurrences of @Union@ or @NoDoc@ represents just one layout.
439 | NilAbove Doc -- text "" $$ x
440 | TextBeside !TextDetails FastInt Doc -- text s <> x
441 | Nest FastInt Doc -- nest k x
442 | Union Doc Doc -- ul `union` ur
443 | NoDoc -- The empty set of documents
444 | Beside Doc Bool Doc -- True <=> space between
445 | Above Doc Bool Doc -- True <=> never overlap
447 type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
450 reduceDoc :: Doc -> RDoc
451 reduceDoc (Beside p g q) = beside p g (reduceDoc q)
452 reduceDoc (Above p g q) = above p g (reduceDoc q)
456 data TextDetails = Chr {-#UNPACK#-}!Char
458 | PStr FastString -- a hashed string
459 | LStr {-#UNPACK#-}!LitString FastInt -- a '\0'-terminated
462 space_text :: TextDetails
464 nl_text :: TextDetails
468 Here are the invariants:
471 The argument of @NilAbove@ is never @Empty@. Therefore
472 a @NilAbove@ occupies at least two lines.
475 The arugment of @TextBeside@ is never @Nest@.
478 The layouts of the two arguments of @Union@ both flatten to the same string.
481 The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
484 The right argument of a union cannot be equivalent to the empty set (@NoDoc@).
485 If the left argument of a union is equivalent to the empty set (@NoDoc@),
486 then the @NoDoc@ appears in the first line.
489 An empty document is always represented by @Empty@.
490 It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.
493 The first line of every layout in the left argument of @Union@
494 is longer than the first line of any layout in the right argument.
495 (1) ensures that the left argument has a first line. In view of (3),
496 this invariant means that the right argument must have at least two
501 -- Arg of a NilAbove is always an RDoc
502 nilAbove_ :: Doc -> Doc
503 nilAbove_ p = LOCAL_ASSERT( _ok p ) NilAbove p
508 -- Arg of a TextBeside is always an RDoc
509 textBeside_ :: TextDetails -> FastInt -> Doc -> Doc
510 textBeside_ s sl p = TextBeside s sl (LOCAL_ASSERT( _ok p ) p)
512 _ok (Nest _ _) = False
515 -- Arg of Nest is always an RDoc
516 nest_ :: FastInt -> Doc -> Doc
517 nest_ k p = Nest k (LOCAL_ASSERT( _ok p ) p)
522 -- Args of union are always RDocs
523 union_ :: Doc -> Doc -> Doc
524 union_ p q = Union (LOCAL_ASSERT( _ok p ) p) (LOCAL_ASSERT( _ok q ) q)
526 _ok (TextBeside _ _ _) = True
527 _ok (NilAbove _) = True
528 _ok (Union _ _) = True
533 Notice the difference between
534 * NoDoc (no documents)
535 * Empty (one empty document; no height and no width)
536 * text "" (a document containing the empty string;
537 one line high, but has no width)
541 *********************************************************
543 \subsection{@empty@, @text@, @nest@, @union@}
545 *********************************************************
553 char c = textBeside_ (Chr c) (_ILIT(1)) Empty
554 text s = case iUnbox (length s) of {sl -> textBeside_ (Str s) sl Empty}
555 ftext :: FastString -> Doc
556 ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty}
557 ptext :: LitString -> Doc
558 ptext s_= case iUnbox (strLength s) of {sl -> textBeside_ (LStr s sl) sl Empty}
559 where s = {-castPtr-} s_
561 #if defined(__GLASGOW_HASKELL__)
562 -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
563 -- intermediate packing/unpacking of the string.
565 "text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
569 nest k p = mkNest (iUnbox k) (reduceDoc p) -- Externally callable version
571 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
572 mkNest :: Int# -> Doc -> Doc
573 mkNest k (Nest k1 p) = mkNest (k +# k1) p
574 mkNest _ NoDoc = NoDoc
575 mkNest _ Empty = Empty
576 mkNest k p | k ==# _ILIT(0) = p -- Worth a try!
577 mkNest k p = nest_ k p
579 -- mkUnion checks for an empty document
580 mkUnion :: Doc -> Doc -> Doc
581 mkUnion Empty _ = Empty
582 mkUnion p q = p `union_` q
585 *********************************************************
587 \subsection{Vertical composition @$$@}
589 *********************************************************
593 p $$ q = Above p False q
594 ($+$) :: Doc -> Doc -> Doc
595 p $+$ q = Above p True q
597 above :: Doc -> Bool -> RDoc -> RDoc
598 above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
599 above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g (_ILIT(0)) (reduceDoc q)
600 above p g q = aboveNest p g (_ILIT(0)) (reduceDoc q)
602 aboveNest :: RDoc -> Bool -> FastInt -> RDoc -> RDoc
603 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
605 aboveNest NoDoc _ _ _ = NoDoc
606 aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
609 aboveNest Empty _ k q = mkNest k q
610 aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k -# k1) q)
611 -- p can't be Empty, so no need for mkNest
613 aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
614 aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
618 Empty -> nilAboveNest g k1 q
619 _ -> aboveNest p g k1 q
620 aboveNest _ _ _ _ = panic "aboveNest: Unhandled case"
624 nilAboveNest :: Bool -> FastInt -> RDoc -> RDoc
625 -- Specification: text s <> nilaboveNest g k q
626 -- = text s <> (text "" $g$ nest k q)
628 nilAboveNest _ _ Empty = Empty -- Here's why the "text s <>" is in the spec!
629 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k +# k1) q
631 nilAboveNest g k q | (not g) && (k ># _ILIT(0)) -- No newline if no overlap
632 = textBeside_ (Str (spaces k)) k q
633 | otherwise -- Put them really above
634 = nilAbove_ (mkNest k q)
638 *********************************************************
640 \subsection{Horizontal composition @<>@}
642 *********************************************************
645 p <> q = Beside p False q
646 p <+> q = Beside p True q
648 beside :: Doc -> Bool -> RDoc -> RDoc
649 -- Specification: beside g p q = p <g> q
651 beside NoDoc _ _ = NoDoc
652 beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q)
654 beside (Nest k p) g q = nest_ k $! beside p g q -- p non-empty
655 beside p@(Beside p1 g1 q1) g2 q2
656 {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2
657 [ && (op1 == <> || op1 == <+>) ] -}
658 | g1 == g2 = beside p1 g1 $! beside q1 g2 q2
659 | otherwise = beside (reduceDoc p) g2 q2
660 beside p@(Above _ _ _) g q = let d = reduceDoc p in d `seq` beside d g q
661 beside (NilAbove p) g q = nilAbove_ $! beside p g q
662 beside (TextBeside s sl p) g q = textBeside_ s sl $! rest
665 Empty -> nilBeside g q
670 nilBeside :: Bool -> RDoc -> RDoc
671 -- Specification: text "" <> nilBeside g p
674 nilBeside _ Empty = Empty -- Hence the text "" in the spec
675 nilBeside g (Nest _ p) = nilBeside g p
676 nilBeside g p | g = textBeside_ space_text (_ILIT(1)) p
680 *********************************************************
682 \subsection{Separate, @sep@, Hughes version}
684 *********************************************************
687 -- Specification: sep ps = oneLiner (hsep ps)
691 sep = sepX True -- Separate with spaces
692 cat = sepX False -- Don't
694 sepX :: Bool -> [Doc] -> Doc
696 sepX x (p:ps) = sep1 x (reduceDoc p) (_ILIT(0)) ps
699 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
700 -- = oneLiner (x <g> nest k (hsep ys))
701 -- `union` x $$ nest k (vcat ys)
703 sep1 :: Bool -> RDoc -> FastInt -> [Doc] -> RDoc
704 sep1 _ NoDoc _ _ = NoDoc
705 sep1 g (p `Union` q) k ys = sep1 g p k ys
707 (aboveNest q False k (reduceDoc (vcat ys)))
709 sep1 g Empty k ys = mkNest k (sepX g ys)
710 sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k -# n) ys)
712 sep1 _ (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
713 sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k -# sl) ys)
714 sep1 _ _ _ _ = panic "sep1: Unhandled case"
716 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
717 -- Called when we have already found some text in the first item
718 -- We have to eat up nests
720 sepNB :: Bool -> Doc -> FastInt -> [Doc] -> Doc
721 sepNB g (Nest _ p) k ys = sepNB g p k ys
723 sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))
725 nilAboveNest False k (reduceDoc (vcat ys))
728 | otherwise = hcat ys
730 sepNB g p k ys = sep1 g p k ys
733 *********************************************************
737 *********************************************************
746 -- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
747 -- (fill (oneLiner p2 : ps))
751 fill :: Bool -> [Doc] -> Doc
753 fill g (p:ps) = fill1 g (reduceDoc p) (_ILIT(0)) ps
756 fill1 :: Bool -> RDoc -> FastInt -> [Doc] -> Doc
757 fill1 _ NoDoc _ _ = NoDoc
758 fill1 g (p `Union` q) k ys = fill1 g p k ys
760 (aboveNest q False k (fill g ys))
762 fill1 g Empty k ys = mkNest k (fill g ys)
763 fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k -# n) ys)
765 fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
766 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k -# sl) ys)
767 fill1 _ _ _ _ = panic "fill1: Unhandled case"
769 fillNB :: Bool -> Doc -> Int# -> [Doc] -> Doc
770 fillNB g (Nest _ p) k ys = fillNB g p k ys
771 fillNB _ Empty _ [] = Empty
772 fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
774 nilAboveNest False k (fill g (y:ys))
776 k1 | g = k -# _ILIT(1)
779 fillNB g p k ys = fill1 g p k ys
783 *********************************************************
785 \subsection{Selecting the best layout}
787 *********************************************************
790 best :: Int -- Line length
791 -> Int -- Ribbon length
793 -> RDoc -- No unions in here!
799 get :: FastInt -- (Remaining) width of line
803 get w (NilAbove p) = nilAbove_ (get w p)
804 get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
805 get w (Nest k p) = nest_ k (get (w -# k) p)
806 get w (p `Union` q) = nicest w r (get w p) (get w q)
807 get _ _ = panic "best/get: Unhandled case"
809 get1 :: FastInt -- (Remaining) width of line
810 -> FastInt -- Amount of first line already eaten up
811 -> Doc -- This is an argument to TextBeside => eat Nests
812 -> Doc -- No unions in here!
814 get1 _ _ Empty = Empty
815 get1 _ _ NoDoc = NoDoc
816 get1 w sl (NilAbove p) = nilAbove_ (get (w -# sl) p)
817 get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl +# tl) p)
818 get1 w sl (Nest _ p) = get1 w sl p
819 get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
821 get1 _ _ _ = panic "best/get1: Unhandled case"
823 nicest :: FastInt -> FastInt -> Doc -> Doc -> Doc
824 nicest w r p q = nicest1 w r (_ILIT(0)) p q
825 nicest1 :: FastInt -> FastInt -> Int# -> Doc -> Doc -> Doc
826 nicest1 w r sl p q | fits ((w `minFastInt` r) -# sl) p = p
829 fits :: FastInt -- Space available
831 -> Bool -- True if *first line* of Doc fits in space available
833 fits n _ | n <# _ILIT(0) = False
836 fits _ (NilAbove _) = True
837 fits n (TextBeside _ sl p) = fits (n -# sl) p
838 fits _ _ = panic "fits: Unhandled case"
841 @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
842 @first@ returns its first argument if it is non-empty, otherwise its second.
845 first :: Doc -> Doc -> Doc
846 first p q | nonEmptySet p = p
849 nonEmptySet :: Doc -> Bool
850 nonEmptySet NoDoc = False
851 nonEmptySet (_ `Union` _) = True
852 nonEmptySet Empty = True
853 nonEmptySet (NilAbove _) = True -- NoDoc always in first line
854 nonEmptySet (TextBeside _ _ p) = nonEmptySet p
855 nonEmptySet (Nest _ p) = nonEmptySet p
856 nonEmptySet _ = panic "nonEmptySet: Unhandled case"
859 @oneLiner@ returns the one-line members of the given set of @Doc@s.
862 oneLiner :: Doc -> Doc
863 oneLiner NoDoc = NoDoc
864 oneLiner Empty = Empty
865 oneLiner (NilAbove _) = NoDoc
866 oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
867 oneLiner (Nest k p) = nest_ k (oneLiner p)
868 oneLiner (p `Union` _) = oneLiner p
869 oneLiner _ = panic "oneLiner: Unhandled case"
874 *********************************************************
876 \subsection{Displaying the best layout}
878 *********************************************************
883 renderStyle Style{mode, lineLength, ribbonsPerLine} doc
884 = fullRender mode lineLength ribbonsPerLine doc ""
887 render doc = showDocWith PageMode doc
889 showDoc :: Doc -> String -> String
890 showDoc doc rest = showDocWithAppend PageMode doc rest
892 showDocWithAppend :: Mode -> Doc -> String -> String
893 showDocWithAppend mode doc rest = fullRender mode 100 1.5 string_txt rest doc
895 showDocWith :: Mode -> Doc -> String
896 showDocWith mode doc = showDocWithAppend mode doc ""
898 string_txt :: TextDetails -> String -> String
899 string_txt (Chr c) s = c:s
900 string_txt (Str s1) s2 = s1 ++ s2
901 string_txt (PStr s1) s2 = unpackFS s1 ++ s2
902 string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
907 fullRender OneLineMode _ _ txt end doc
908 = lay (reduceDoc doc)
910 lay NoDoc = cant_fail
911 lay (Union _ q) = lay q -- Second arg can't be NoDoc
912 lay (Nest _ p) = lay p
914 lay (NilAbove p) = space_text `txt` lay p -- NoDoc always on
916 lay (TextBeside s _ p) = s `txt` lay p
917 lay _ = panic "fullRender/OneLineMode/lay: Unhandled case"
919 fullRender LeftMode _ _ txt end doc
920 = lay (reduceDoc doc)
922 lay NoDoc = cant_fail
923 lay (Union p q) = lay (first p q)
924 lay (Nest _ p) = lay p
926 lay (NilAbove p) = nl_text `txt` lay p -- NoDoc always on first line
927 lay (TextBeside s _ p) = s `txt` lay p
928 lay _ = panic "fullRender/LeftMode/lay: Unhandled case"
930 fullRender mode line_length ribbons_per_line txt end doc
931 = display mode line_length ribbon_length txt end best_doc
933 best_doc = best hacked_line_length ribbon_length (reduceDoc doc)
935 hacked_line_length, ribbon_length :: Int
936 ribbon_length = round (fromIntegral line_length / ribbons_per_line)
937 hacked_line_length = case mode of
938 ZigZagMode -> maxBound
941 display :: Mode -> Int -> Int -> (TextDetails -> t -> t) -> t -> Doc -> t
942 display mode page_width ribbon_width txt end doc
943 = case (iUnbox page_width) -# (iUnbox ribbon_width) of { gap_width ->
944 case gap_width `quotFastInt` _ILIT(2) of { shift ->
946 lay k (Nest k1 p) = lay (k +# k1) p
949 lay k (NilAbove p) = nl_text `txt` lay k p
951 lay k (TextBeside s sl p)
953 ZigZagMode | k >=# gap_width
955 Str (multi_ch shift '/') `txt` (
957 lay1 (k -# shift) s sl p)))
961 Str (multi_ch shift '\\') `txt` (
963 lay1 (k +# shift) s sl p )))
966 lay _ _ = panic "display/lay: Unhandled case"
968 lay1 k s sl p = indent k (s `txt` lay2 (k +# sl) p)
970 lay2 k (NilAbove p) = nl_text `txt` lay k p
971 lay2 k (TextBeside s sl p) = s `txt` (lay2 (k +# sl) p)
972 lay2 k (Nest _ p) = lay2 k p
974 lay2 _ _ = panic "display/lay2: Unhandled case"
976 -- optimise long indentations using LitString chunks of 8 spaces
977 indent n r | n >=# _ILIT(8) = LStr SLIT(" ") (_ILIT(8)) `txt`
978 indent (n -# _ILIT(8)) r
979 | otherwise = Str (spaces n) `txt` r
985 cant_fail = error "easy_display: NoDoc"
987 multi_ch :: Int# -> Char -> String
988 multi_ch n ch | n <=# _ILIT(0) = ""
989 | otherwise = ch : multi_ch (n -# _ILIT(1)) ch
991 spaces :: Int# -> String
992 spaces n | n <=# _ILIT(0) = ""
993 | otherwise = ' ' : spaces (n -# _ILIT(1))
999 pprCols = 120 -- could make configurable
1001 printDoc :: Mode -> Handle -> Doc -> IO ()
1002 printDoc LeftMode hdl doc
1003 = do { printLeftRender hdl doc; hFlush hdl }
1004 printDoc mode hdl doc
1005 = do { fullRender mode pprCols 1.5 put done doc ;
1008 put (Chr c) next = hPutChar hdl c >> next
1009 put (Str s) next = hPutStr hdl s >> next
1010 put (PStr s) next = hPutFS hdl s >> next
1011 put (LStr s l) next = hPutLitString hdl s l >> next
1013 done = hPutChar hdl '\n'
1015 -- some versions of hPutBuf will barf if the length is zero
1016 hPutLitString :: Handle -> Ptr a -> Int# -> IO ()
1017 hPutLitString handle a l = if l ==# _ILIT(0)
1019 else hPutBuf handle a (iBox l)
1021 -- Printing output in LeftMode is performance critical: it's used when
1022 -- dumping C and assembly output, so we allow ourselves a few dirty
1025 -- (1) we specialise fullRender for LeftMode with IO output.
1027 -- (2) we add a layer of buffering on top of Handles. Handles
1028 -- don't perform well with lots of hPutChars, which is mostly
1029 -- what we're doing here, because Handles have to be thread-safe
1030 -- and async exception-safe. We only have a single thread and don't
1031 -- care about exceptions, so we add a layer of fast buffering
1032 -- over the Handle interface.
1034 -- (3) a few hacks in layLeft below to convince GHC to generate the right
1037 printLeftRender :: Handle -> Doc -> IO ()
1038 printLeftRender hdl doc = do
1039 b <- newBufHandle hdl
1040 layLeft b (reduceDoc doc)
1043 -- HACK ALERT! the "return () >>" below convinces GHC to eta-expand
1044 -- this function with the IO state lambda. Otherwise we end up with
1045 -- closures in all the case branches.
1046 layLeft :: BufHandle -> Doc -> IO ()
1047 layLeft b _ | b `seq` False = undefined -- make it strict in b
1048 layLeft _ NoDoc = cant_fail
1049 layLeft b (Union p q) = return () >> layLeft b (first p q)
1050 layLeft b (Nest _ p) = return () >> layLeft b p
1051 layLeft b Empty = bPutChar b '\n'
1052 layLeft b (NilAbove p) = bPutChar b '\n' >> layLeft b p
1053 layLeft b (TextBeside s _ p) = put b s >> layLeft b p
1055 put b _ | b `seq` False = undefined
1056 put b (Chr c) = bPutChar b c
1057 put b (Str s) = bPutStr b s
1058 put b (PStr s) = bPutFS b s
1059 put b (LStr s l) = bPutLitString b s l
1060 layLeft _ _ = panic "layLeft: Unhandled case"