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
156 -- The above warning supression flag is a temporary kludge.
157 -- While working on this module you are encouraged to remove it and fix
158 -- any warnings in the module. See
159 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
164 Mode(..), TextDetails(..),
166 empty, isEmpty, nest,
168 text, char, ftext, ptext,
169 int, integer, float, double, rational,
170 parens, brackets, braces, quotes, doubleQuotes,
171 semi, comma, colon, space, equals,
172 lparen, rparen, lbrack, rbrack, lbrace, rbrace, cparen,
174 (<>), (<+>), hcat, hsep,
181 -- renderStyle, -- Haskell 1.3 only
182 render, fullRender, printDoc, showDocWith
185 #include "HsVersions.h"
192 import Numeric (fromRat)
195 import GHC.Base ( unpackCString# )
196 import GHC.Ptr ( Ptr(..) )
198 -- Don't import Util( assertPanic ) because it makes a loop in the module structure
207 *********************************************************
209 \subsection{CPP magic so that we can compile with both GHC and Hugs}
211 *********************************************************
213 The library uses unboxed types to get a bit more speed, but these CPP macros
214 allow you to use either GHC or Hugs. To get GHC, just set the CPP variable
219 #if defined(__GLASGOW_HASKELL__)
223 -- Disable ASSERT checks; they are expensive!
224 #define LOCAL_ASSERT(x)
227 #define IBOX(x) (I# (x))
230 #define NEGATE negateInt#
236 #define DIV `quotInt#`
240 #define MAXINT maxBound
246 #define LOCAL_ASSERT(x)
251 #define NEGATE negate
260 #define MAXINT maxBound
267 *********************************************************
269 \subsection{The interface}
271 *********************************************************
273 The primitive @Doc@ values
277 isEmpty :: Doc -> Bool
278 text :: String -> Doc
281 semi, comma, colon, space, equals :: Doc
282 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
284 parens, brackets, braces :: Doc -> Doc
285 quotes, doubleQuotes :: Doc -> Doc
288 integer :: Integer -> Doc
289 float :: Float -> Doc
290 double :: Double -> Doc
291 rational :: Rational -> Doc
294 Combining @Doc@ values
297 (<>) :: Doc -> Doc -> Doc -- Beside
298 hcat :: [Doc] -> Doc -- List version of <>
299 (<+>) :: Doc -> Doc -> Doc -- Beside, separated by space
300 hsep :: [Doc] -> Doc -- List version of <+>
302 ($$) :: Doc -> Doc -> Doc -- Above; if there is no
303 -- overlap it "dovetails" the two
304 vcat :: [Doc] -> Doc -- List version of $$
306 cat :: [Doc] -> Doc -- Either hcat or vcat
307 sep :: [Doc] -> Doc -- Either hsep or vcat
308 fcat :: [Doc] -> Doc -- ``Paragraph fill'' version of cat
309 fsep :: [Doc] -> Doc -- ``Paragraph fill'' version of sep
311 nest :: Int -> Doc -> Doc -- Nested
317 hang :: Doc -> Int -> Doc -> Doc
318 punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
321 Displaying @Doc@ values.
324 instance SHOW Doc where
325 showsPrec prec doc cont = showDoc doc cont
327 render :: Doc -> String -- Uses default style
329 -> Int -- Line length
330 -> Float -- Ribbons per line
331 -> (TextDetails -> a -> a) -- What to do with text
332 -> a -- What to do at the end
336 {- When we start using 1.3
337 renderStyle :: Style -> Doc -> String
338 data Style = Style { lineLength :: Int, -- In chars
339 ribbonsPerLine :: Float, -- Ratio of ribbon length to line length
342 style :: Style -- The default style
343 style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
346 data Mode = PageMode -- Normal
347 | ZigZagMode -- With zig-zag cuts
348 | LeftMode -- No indentation, infinitely long lines
349 | OneLineMode -- All on one line
354 *********************************************************
356 \subsection{The @Doc@ calculus}
358 *********************************************************
360 The @Doc@ combinators satisfy the following laws:
364 <a1> (x $$ y) $$ z = x $$ (y $$ z)
372 <b1> (x <> y) <> z = x <> (y <> z)
373 <b2> empty <> x = empty
380 <t1> text s <> text t = text (s++t)
381 <t2> text "" <> x = x, if x non-empty
386 <n2> nest k (nest k' x) = nest (k+k') x
387 <n3> nest k (x <> y) = nest k z <> nest k y
388 <n4> nest k (x $$ y) = nest k x $$ nest k y
389 <n5> nest k empty = empty
390 <n6> x <> nest k y = x <> y, if x non-empty
392 ** Note the side condition on <n6>! It is this that
393 ** makes it OK for empty to be a left unit for <>.
397 <m1> (text s <> x) $$ y = text s <> ((text "" <> x)) $$
400 <m2> (x $$ y) <> z = x $$ (y <> z)
404 Laws for list versions
405 ~~~~~~~~~~~~~~~~~~~~~~
406 <l1> sep (ps++[empty]++qs) = sep (ps ++ qs)
407 ...ditto hsep, hcat, vcat, fill...
409 <l2> nest k (sep ps) = sep (map (nest k) ps)
410 ...ditto hsep, hcat, vcat, fill...
414 <o1> oneLiner (nest k p) = nest k (oneLiner p)
415 <o2> oneLiner (x <> y) = oneLiner x <> oneLiner y
419 You might think that the following verion of <m1> would
422 <3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$
425 But it doesn't work, for if x=empty, we would have
427 text s $$ y = text s <> (empty $$ nest (-length s) y)
428 = text s <> nest (-length s) y
433 *********************************************************
435 \subsection{Simple derived definitions}
437 *********************************************************
452 int n = text (show n)
453 integer n = text (show n)
454 float n = text (show n)
455 double n = text (show n)
456 rational n = text (show (fromRat n :: Double))
457 --rational n = text (show (fromRationalX n)) -- _showRational 30 n)
459 quotes p = char '`' <> p <> char '\''
460 doubleQuotes p = char '"' <> p <> char '"'
461 parens p = char '(' <> p <> char ')'
462 brackets p = char '[' <> p <> char ']'
463 braces p = char '{' <> p <> char '}'
468 hcat = foldr (<>) empty
469 hsep = foldr (<+>) empty
470 vcat = foldr ($$) empty
472 hang d1 n d2 = sep [d1, nest n d2]
475 punctuate p (d:ds) = go d ds
478 go d (e:es) = (d <> p) : go e es
482 *********************************************************
484 \subsection{The @Doc@ data type}
486 *********************************************************
488 A @Doc@ represents a {\em set} of layouts. A @Doc@ with
489 no occurrences of @Union@ or @NoDoc@ represents just one layout.
493 | NilAbove Doc -- text "" $$ x
494 | TextBeside !TextDetails INT Doc -- text s <> x
495 | Nest INT Doc -- nest k x
496 | Union Doc Doc -- ul `union` ur
497 | NoDoc -- The empty set of documents
498 | Beside Doc Bool Doc -- True <=> space between
499 | Above Doc Bool Doc -- True <=> never overlap
501 type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
504 reduceDoc :: Doc -> RDoc
505 reduceDoc (Beside p g q) = beside p g (reduceDoc q)
506 reduceDoc (Above p g q) = above p g (reduceDoc q)
510 data TextDetails = Chr {-#UNPACK#-}!Char
512 | PStr FastString -- a hashed string
513 | LStr Addr# Int# -- a '\0'-terminated array of bytes
519 Here are the invariants:
522 The argument of @NilAbove@ is never @Empty@. Therefore
523 a @NilAbove@ occupies at least two lines.
526 The arugment of @TextBeside@ is never @Nest@.
529 The layouts of the two arguments of @Union@ both flatten to the same string.
532 The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
535 The right argument of a union cannot be equivalent to the empty set (@NoDoc@).
536 If the left argument of a union is equivalent to the empty set (@NoDoc@),
537 then the @NoDoc@ appears in the first line.
540 An empty document is always represented by @Empty@.
541 It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.
544 The first line of every layout in the left argument of @Union@
545 is longer than the first line of any layout in the right argument.
546 (1) ensures that the left argument has a first line. In view of (3),
547 this invariant means that the right argument must have at least two
552 -- Arg of a NilAbove is always an RDoc
553 nilAbove_ p = LOCAL_ASSERT( ok p ) NilAbove p
558 -- Arg of a TextBeside is always an RDoc
559 textBeside_ s sl p = TextBeside s sl (LOCAL_ASSERT( ok p ) p)
561 ok (Nest _ _) = False
564 -- Arg of Nest is always an RDoc
565 nest_ k p = Nest k (LOCAL_ASSERT( ok p ) p)
570 -- Args of union are always RDocs
571 union_ p q = Union (LOCAL_ASSERT( ok p ) p) (LOCAL_ASSERT( ok q ) q)
573 ok (TextBeside _ _ _) = True
574 ok (NilAbove _) = True
575 ok (Union _ _) = True
580 Notice the difference between
581 * NoDoc (no documents)
582 * Empty (one empty document; no height and no width)
583 * text "" (a document containing the empty string;
584 one line high, but has no width)
588 *********************************************************
590 \subsection{@empty@, @text@, @nest@, @union@}
592 *********************************************************
600 char c = textBeside_ (Chr c) 1# Empty
601 text s = case length s of {IBOX(sl) -> textBeside_ (Str s) sl Empty}
602 ftext s = case lengthFS s of {IBOX(sl) -> textBeside_ (PStr s) sl Empty}
603 ptext (Ptr s) = case strLength (Ptr s) of {IBOX(sl) -> textBeside_ (LStr s sl) sl Empty}
605 -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
606 -- intermediate packing/unpacking of the string.
608 "text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
611 nest IBOX(k) p = mkNest k (reduceDoc p) -- Externally callable version
613 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
614 mkNest k (Nest k1 p) = mkNest (k PLUS k1) p
615 mkNest k NoDoc = NoDoc
616 mkNest k Empty = Empty
617 mkNest ILIT(0) p = p -- Worth a try!
618 mkNest k p = nest_ k p
620 -- mkUnion checks for an empty document
621 mkUnion Empty q = Empty
622 mkUnion p q = p `union_` q
625 *********************************************************
627 \subsection{Vertical composition @$$@}
629 *********************************************************
633 p $$ q = Above p False q
634 p $+$ q = Above p True q
636 above :: Doc -> Bool -> RDoc -> RDoc
637 above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
638 above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g ILIT(0) (reduceDoc q)
639 above p g q = aboveNest p g ILIT(0) (reduceDoc q)
641 aboveNest :: RDoc -> Bool -> INT -> RDoc -> RDoc
642 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
644 aboveNest NoDoc g k q = NoDoc
645 aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
648 aboveNest Empty g k q = mkNest k q
649 aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k MINUS k1) q)
650 -- p can't be Empty, so no need for mkNest
652 aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
653 aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
657 Empty -> nilAboveNest g k1 q
658 other -> aboveNest p g k1 q
662 nilAboveNest :: Bool -> INT -> RDoc -> RDoc
663 -- Specification: text s <> nilaboveNest g k q
664 -- = text s <> (text "" $g$ nest k q)
666 nilAboveNest g k Empty = Empty -- Here's why the "text s <>" is in the spec!
667 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k PLUS k1) q
669 nilAboveNest g k q | (not g) && (k GR ILIT(0)) -- No newline if no overlap
670 = textBeside_ (Str (spaces k)) k q
671 | otherwise -- Put them really above
672 = nilAbove_ (mkNest k q)
676 *********************************************************
678 \subsection{Horizontal composition @<>@}
680 *********************************************************
683 p <> q = Beside p False q
684 p <+> q = Beside p True q
686 beside :: Doc -> Bool -> RDoc -> RDoc
687 -- Specification: beside g p q = p <g> q
689 beside NoDoc g q = NoDoc
690 beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q)
692 beside (Nest k p) g q = nest_ k $! beside p g q -- p non-empty
693 beside p@(Beside p1 g1 q1) g2 q2
694 {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2
695 [ && (op1 == <> || op1 == <+>) ] -}
696 | g1 == g2 = beside p1 g1 $! beside q1 g2 q2
697 | otherwise = beside (reduceDoc p) g2 q2
698 beside p@(Above _ _ _) g q = let d = reduceDoc p in d `seq` beside d g q
699 beside (NilAbove p) g q = nilAbove_ $! beside p g q
700 beside (TextBeside s sl p) g q = textBeside_ s sl $! rest
703 Empty -> nilBeside g q
704 other -> beside p g q
708 nilBeside :: Bool -> RDoc -> RDoc
709 -- Specification: text "" <> nilBeside g p
712 nilBeside g Empty = Empty -- Hence the text "" in the spec
713 nilBeside g (Nest _ p) = nilBeside g p
714 nilBeside g p | g = textBeside_ space_text ILIT(1) p
718 *********************************************************
720 \subsection{Separate, @sep@, Hughes version}
722 *********************************************************
725 -- Specification: sep ps = oneLiner (hsep ps)
729 sep = sepX True -- Separate with spaces
730 cat = sepX False -- Don't
733 sepX x (p:ps) = sep1 x (reduceDoc p) ILIT(0) ps
736 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
737 -- = oneLiner (x <g> nest k (hsep ys))
738 -- `union` x $$ nest k (vcat ys)
740 sep1 :: Bool -> RDoc -> INT -> [Doc] -> RDoc
741 sep1 g NoDoc k ys = NoDoc
742 sep1 g (p `Union` q) k ys = sep1 g p k ys
744 (aboveNest q False k (reduceDoc (vcat ys)))
746 sep1 g Empty k ys = mkNest k (sepX g ys)
747 sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k MINUS n) ys)
749 sep1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
750 sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k MINUS sl) ys)
752 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
753 -- Called when we have already found some text in the first item
754 -- We have to eat up nests
756 sepNB g (Nest _ p) k ys = sepNB g p k ys
758 sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))
760 nilAboveNest False k (reduceDoc (vcat ys))
763 | otherwise = hcat ys
765 sepNB g p k ys = sep1 g p k ys
768 *********************************************************
772 *********************************************************
781 -- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
782 -- (fill (oneLiner p2 : ps))
787 fill g (p:ps) = fill1 g (reduceDoc p) ILIT(0) ps
790 fill1 :: Bool -> RDoc -> INT -> [Doc] -> Doc
791 fill1 g NoDoc k ys = NoDoc
792 fill1 g (p `Union` q) k ys = fill1 g p k ys
794 (aboveNest q False k (fill g ys))
796 fill1 g Empty k ys = mkNest k (fill g ys)
797 fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k MINUS n) ys)
799 fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
800 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k MINUS sl) ys)
802 fillNB g (Nest _ p) k ys = fillNB g p k ys
803 fillNB g Empty k [] = Empty
804 fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
806 nilAboveNest False k (fill g (y:ys))
808 k1 | g = k MINUS ILIT(1)
811 fillNB g p k ys = fill1 g p k ys
815 *********************************************************
817 \subsection{Selecting the best layout}
819 *********************************************************
822 best :: Int -- Line length
823 -> Int -- Ribbon length
825 -> RDoc -- No unions in here!
827 best IBOX(w) IBOX(r) p
830 get :: INT -- (Remaining) width of line
834 get w (NilAbove p) = nilAbove_ (get w p)
835 get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
836 get w (Nest k p) = nest_ k (get (w MINUS k) p)
837 get w (p `Union` q) = nicest w r (get w p) (get w q)
839 get1 :: INT -- (Remaining) width of line
840 -> INT -- Amount of first line already eaten up
841 -> Doc -- This is an argument to TextBeside => eat Nests
842 -> Doc -- No unions in here!
844 get1 w sl Empty = Empty
845 get1 w sl NoDoc = NoDoc
846 get1 w sl (NilAbove p) = nilAbove_ (get (w MINUS sl) p)
847 get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl PLUS tl) p)
848 get1 w sl (Nest k p) = get1 w sl p
849 get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
852 nicest w r p q = nicest1 w r ILIT(0) p q
853 nicest1 w r sl p q | fits ((w `minn` r) MINUS sl) p = p
856 fits :: INT -- Space available
858 -> Bool -- True if *first line* of Doc fits in space available
860 fits n p | n LT ILIT(0) = False
863 fits n (NilAbove _) = True
864 fits n (TextBeside _ sl p) = fits (n MINUS sl) p
866 minn x y | x LT y = x
870 @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
871 @first@ returns its first argument if it is non-empty, otherwise its second.
874 first p q | nonEmptySet p = p
877 nonEmptySet NoDoc = False
878 nonEmptySet (p `Union` q) = True
879 nonEmptySet Empty = True
880 nonEmptySet (NilAbove p) = True -- NoDoc always in first line
881 nonEmptySet (TextBeside _ _ p) = nonEmptySet p
882 nonEmptySet (Nest _ p) = nonEmptySet p
885 @oneLiner@ returns the one-line members of the given set of @Doc@s.
888 oneLiner :: Doc -> Doc
889 oneLiner NoDoc = NoDoc
890 oneLiner Empty = Empty
891 oneLiner (NilAbove p) = NoDoc
892 oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
893 oneLiner (Nest k p) = nest_ k (oneLiner p)
894 oneLiner (p `Union` q) = oneLiner p
899 *********************************************************
901 \subsection{Displaying the best layout}
903 *********************************************************
908 renderStyle Style{mode, lineLength, ribbonsPerLine} doc
909 = fullRender mode lineLength ribbonsPerLine doc ""
912 render doc = showDocWith PageMode doc
913 showDoc doc rest = showDocWithAppend PageMode doc rest
915 showDocWithAppend :: Mode -> Doc -> String -> String
916 showDocWithAppend mode doc rest = fullRender mode 100 1.5 string_txt rest doc
918 showDocWith :: Mode -> Doc -> String
919 showDocWith mode doc = showDocWithAppend mode doc ""
921 string_txt (Chr c) s = c:s
922 string_txt (Str s1) s2 = s1 ++ s2
923 string_txt (PStr s1) s2 = unpackFS s1 ++ s2
924 string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
926 unpackLitString addr =
930 | ch `eqChar#` '\0'# = []
931 | otherwise = C# ch : unpack (nh +# 1#)
933 ch = indexCharOffAddr# addr nh
938 fullRender OneLineMode _ _ txt end doc
939 = lay (reduceDoc doc)
941 lay NoDoc = cant_fail
942 lay (Union p q) = (lay q) -- Second arg can't be NoDoc
943 lay (Nest k p) = lay p
945 lay (NilAbove p) = space_text `txt` lay p -- NoDoc always on first line
946 lay (TextBeside s sl p) = s `txt` lay p
948 fullRender LeftMode _ _ txt end doc
949 = lay (reduceDoc doc)
951 lay NoDoc = cant_fail
952 lay (Union p q) = lay (first p q)
953 lay (Nest k p) = lay p
955 lay (NilAbove p) = nl_text `txt` lay p -- NoDoc always on first line
956 lay (TextBeside s sl p) = s `txt` lay p
958 fullRender mode line_length ribbons_per_line txt end doc
959 = display mode line_length ribbon_length txt end best_doc
961 best_doc = best hacked_line_length ribbon_length (reduceDoc doc)
963 hacked_line_length, ribbon_length :: Int
964 ribbon_length = round (fromIntegral line_length / ribbons_per_line)
965 hacked_line_length = case mode of { ZigZagMode -> MAXINT; other -> line_length }
967 display mode IBOX(page_width) IBOX(ribbon_width) txt end doc
968 = case page_width MINUS ribbon_width of { gap_width ->
969 case gap_width DIV ILIT(2) of { shift ->
971 lay k (Nest k1 p) = lay (k PLUS k1) p
974 lay k (NilAbove p) = nl_text `txt` lay k p
976 lay k (TextBeside s sl p)
978 ZigZagMode | k GREQ gap_width
980 Str (multi_ch shift '/') `txt` (
982 lay1 (k MINUS shift) s sl p)))
986 Str (multi_ch shift '\\') `txt` (
988 lay1 (k PLUS shift) s sl p )))
990 other -> lay1 k s sl p
992 lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k PLUS sl) p)
994 lay2 k (NilAbove p) = nl_text `txt` lay k p
995 lay2 k (TextBeside s sl p) = s `txt` (lay2 (k PLUS sl) p)
996 lay2 k (Nest _ p) = lay2 k p
1002 cant_fail = error "easy_display: NoDoc"
1004 indent n | n GREQ ILIT(8) = '\t' : indent (n MINUS ILIT(8))
1005 | otherwise = spaces n
1007 multi_ch n ch | n LTEQ ILIT(0) = ""
1008 | otherwise = ch : multi_ch (n MINUS ILIT(1)) ch
1010 spaces n | n LTEQ ILIT(0) = ""
1011 | otherwise = ' ' : spaces (n MINUS ILIT(1))
1015 pprCols = (120 :: Int) -- could make configurable
1017 printDoc :: Mode -> Handle -> Doc -> IO ()
1018 printDoc LeftMode hdl doc
1019 = do { printLeftRender hdl doc; hFlush hdl }
1020 printDoc mode hdl doc
1021 = do { fullRender mode pprCols 1.5 put done doc ;
1024 put (Chr c) next = hPutChar hdl c >> next
1025 put (Str s) next = hPutStr hdl s >> next
1026 put (PStr s) next = hPutFS hdl s >> next
1027 put (LStr s l) next = hPutLitString hdl s l >> next
1029 done = hPutChar hdl '\n'
1031 -- some versions of hPutBuf will barf if the length is zero
1032 hPutLitString handle a# 0# = return ()
1033 hPutLitString handle a# l#
1034 = hPutBuf handle (Ptr a#) (I# l#)
1036 -- Printing output in LeftMode is performance critical: it's used when
1037 -- dumping C and assembly output, so we allow ourselves a few dirty
1040 -- (1) we specialise fullRender for LeftMode with IO output.
1042 -- (2) we add a layer of buffering on top of Handles. Handles
1043 -- don't perform well with lots of hPutChars, which is mostly
1044 -- what we're doing here, because Handles have to be thread-safe
1045 -- and async exception-safe. We only have a single thread and don't
1046 -- care about exceptions, so we add a layer of fast buffering
1047 -- over the Handle interface.
1049 -- (3) a few hacks in layLeft below to convince GHC to generate the right
1052 printLeftRender :: Handle -> Doc -> IO ()
1053 printLeftRender hdl doc = do
1054 b <- newBufHandle hdl
1055 layLeft b (reduceDoc doc)
1058 -- HACK ALERT! the "return () >>" below convinces GHC to eta-expand
1059 -- this function with the IO state lambda. Otherwise we end up with
1060 -- closures in all the case branches.
1061 layLeft b _ | b `seq` False = undefined -- make it strict in b
1062 layLeft b NoDoc = cant_fail
1063 layLeft b (Union p q) = return () >> layLeft b (first p q)
1064 layLeft b (Nest k p) = return () >> layLeft b p
1065 layLeft b Empty = bPutChar b '\n'
1066 layLeft b (NilAbove p) = bPutChar b '\n' >> layLeft b p
1067 layLeft b (TextBeside s sl p) = put b s >> layLeft b p
1069 put b _ | b `seq` False = undefined
1070 put b (Chr c) = bPutChar b c
1071 put b (Str s) = bPutStr b s
1072 put b (PStr s) = bPutFS b s
1073 put b (LStr s l) = bPutLitString b s l