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 itc 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,
167 (<>), (<+>), hcat, hsep,
174 -- renderStyle, -- Haskell 1.3 only
175 render, fullRender, printDoc, showDocWith
178 #include "HsVersions.h"
182 import PrimPacked ( strLength )
186 import Numeric (fromRat)
189 #if __GLASGOW_HASKELL__ < 503
190 import IOExts ( hPutBufFull )
192 import System.IO ( hPutBuf )
195 #if __GLASGOW_HASKELL__ < 503
196 import PrelBase ( unpackCString# )
198 import GHC.Base ( unpackCString# )
201 import PrimPacked ( Ptr(..) )
203 -- Don't import Util( assertPanic ) because it makes a loop in the module structure
212 *********************************************************
214 \subsection{CPP magic so that we can compile with both GHC and Hugs}
216 *********************************************************
218 The library uses unboxed types to get a bit more speed, but these CPP macros
219 allow you to use either GHC or Hugs. To get GHC, just set the CPP variable
224 #if defined(__GLASGOW_HASKELL__)
228 -- Disable ASSERT checks; they are expensive!
229 #define LOCAL_ASSERT(x)
232 #define IBOX(x) (I# (x))
235 #define NEGATE negateInt#
240 #define DIV `quotInt#`
244 #define MAXINT maxBound
250 #define LOCAL_ASSERT(x)
255 #define NEGATE negate
264 #define MAXINT maxBound
271 *********************************************************
273 \subsection{The interface}
275 *********************************************************
277 The primitive @Doc@ values
281 isEmpty :: Doc -> Bool
282 text :: String -> Doc
285 semi, comma, colon, space, equals :: Doc
286 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
288 parens, brackets, braces :: Doc -> Doc
289 quotes, doubleQuotes :: Doc -> Doc
292 integer :: Integer -> Doc
293 float :: Float -> Doc
294 double :: Double -> Doc
295 rational :: Rational -> Doc
298 Combining @Doc@ values
301 (<>) :: Doc -> Doc -> Doc -- Beside
302 hcat :: [Doc] -> Doc -- List version of <>
303 (<+>) :: Doc -> Doc -> Doc -- Beside, separated by space
304 hsep :: [Doc] -> Doc -- List version of <+>
306 ($$) :: Doc -> Doc -> Doc -- Above; if there is no
307 -- overlap it "dovetails" the two
308 vcat :: [Doc] -> Doc -- List version of $$
310 cat :: [Doc] -> Doc -- Either hcat or vcat
311 sep :: [Doc] -> Doc -- Either hsep or vcat
312 fcat :: [Doc] -> Doc -- ``Paragraph fill'' version of cat
313 fsep :: [Doc] -> Doc -- ``Paragraph fill'' version of sep
315 nest :: Int -> Doc -> Doc -- Nested
321 hang :: Doc -> Int -> Doc -> Doc
322 punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
325 Displaying @Doc@ values.
328 instance SHOW Doc where
329 showsPrec prec doc cont = showDoc doc cont
331 render :: Doc -> String -- Uses default style
333 -> Int -- Line length
334 -> Float -- Ribbons per line
335 -> (TextDetails -> a -> a) -- What to do with text
336 -> a -- What to do at the end
340 {- When we start using 1.3
341 renderStyle :: Style -> Doc -> String
342 data Style = Style { lineLength :: Int, -- In chars
343 ribbonsPerLine :: Float, -- Ratio of ribbon length to line length
346 style :: Style -- The default style
347 style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
350 data Mode = PageMode -- Normal
351 | ZigZagMode -- With zig-zag cuts
352 | LeftMode -- No indentation, infinitely long lines
353 | OneLineMode -- All on one line
358 *********************************************************
360 \subsection{The @Doc@ calculus}
362 *********************************************************
364 The @Doc@ combinators satisfy the following laws:
368 <a1> (x $$ y) $$ z = x $$ (y $$ z)
376 <b1> (x <> y) <> z = x <> (y <> z)
377 <b2> empty <> x = empty
384 <t1> text s <> text t = text (s++t)
385 <t2> text "" <> x = x, if x non-empty
390 <n2> nest k (nest k' x) = nest (k+k') x
391 <n3> nest k (x <> y) = nest k z <> nest k y
392 <n4> nest k (x $$ y) = nest k x $$ nest k y
393 <n5> nest k empty = empty
394 <n6> x <> nest k y = x <> y, if x non-empty
396 ** Note the side condition on <n6>! It is this that
397 ** makes it OK for empty to be a left unit for <>.
401 <m1> (text s <> x) $$ y = text s <> ((text "" <> x)) $$
404 <m2> (x $$ y) <> z = x $$ (y <> z)
408 Laws for list versions
409 ~~~~~~~~~~~~~~~~~~~~~~
410 <l1> sep (ps++[empty]++qs) = sep (ps ++ qs)
411 ...ditto hsep, hcat, vcat, fill...
413 <l2> nest k (sep ps) = sep (map (nest k) ps)
414 ...ditto hsep, hcat, vcat, fill...
418 <o1> oneLiner (nest k p) = nest k (oneLiner p)
419 <o2> oneLiner (x <> y) = oneLiner x <> oneLiner y
423 You might think that the following verion of <m1> would
426 <3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$
429 But it doesn't work, for if x=empty, we would have
431 text s $$ y = text s <> (empty $$ nest (-length s) y)
432 = text s <> nest (-length s) y
437 *********************************************************
439 \subsection{Simple derived definitions}
441 *********************************************************
456 int n = text (show n)
457 integer n = text (show n)
458 float n = text (show n)
459 double n = text (show n)
460 rational n = text (show (fromRat n))
461 --rational n = text (show (fromRationalX n)) -- _showRational 30 n)
463 quotes p = char '`' <> p <> char '\''
464 doubleQuotes p = char '"' <> p <> char '"'
465 parens p = char '(' <> p <> char ')'
466 brackets p = char '[' <> p <> char ']'
467 braces p = char '{' <> p <> char '}'
470 hcat = foldr (<>) empty
471 hsep = foldr (<+>) empty
472 vcat = foldr ($$) empty
474 hang d1 n d2 = sep [d1, nest n d2]
477 punctuate p (d:ds) = go d ds
480 go d (e:es) = (d <> p) : go e es
484 *********************************************************
486 \subsection{The @Doc@ data type}
488 *********************************************************
490 A @Doc@ represents a {\em set} of layouts. A @Doc@ with
491 no occurrences of @Union@ or @NoDoc@ represents just one layout.
495 | NilAbove Doc -- text "" $$ x
496 | TextBeside !TextDetails INT Doc -- text s <> x
497 | Nest INT Doc -- nest k x
498 | Union Doc Doc -- ul `union` ur
499 | NoDoc -- The empty set of documents
500 | Beside Doc Bool Doc -- True <=> space between
501 | Above Doc Bool Doc -- True <=> never overlap
503 type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
506 reduceDoc :: Doc -> RDoc
507 reduceDoc (Beside p g q) = beside p g (reduceDoc q)
508 reduceDoc (Above p g q) = above p g (reduceDoc q)
512 data TextDetails = Chr {-#UNPACK#-}!Char
514 | PStr FastString -- a hashed string
515 | LStr Addr# Int# -- a '\0'-terminated array of bytes
521 Here are the invariants:
524 The argument of @NilAbove@ is never @Empty@. Therefore
525 a @NilAbove@ occupies at least two lines.
528 The arugment of @TextBeside@ is never @Nest@.
531 The layouts of the two arguments of @Union@ both flatten to the same string.
534 The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
537 The right argument of a union cannot be equivalent to the empty set (@NoDoc@).
538 If the left argument of a union is equivalent to the empty set (@NoDoc@),
539 then the @NoDoc@ appears in the first line.
542 An empty document is always represented by @Empty@.
543 It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.
546 The first line of every layout in the left argument of @Union@
547 is longer than the first line of any layout in the right argument.
548 (1) ensures that the left argument has a first line. In view of (3),
549 this invariant means that the right argument must have at least two
554 -- Arg of a NilAbove is always an RDoc
555 nilAbove_ p = LOCAL_ASSERT( ok p ) NilAbove p
560 -- Arg of a TextBeside is always an RDoc
561 textBeside_ s sl p = TextBeside s sl (LOCAL_ASSERT( ok p ) p)
563 ok (Nest _ _) = False
566 -- Arg of Nest is always an RDoc
567 nest_ k p = Nest k (LOCAL_ASSERT( ok p ) p)
572 -- Args of union are always RDocs
573 union_ p q = Union (LOCAL_ASSERT( ok p ) p) (LOCAL_ASSERT( ok q ) q)
575 ok (TextBeside _ _ _) = True
576 ok (NilAbove _) = True
577 ok (Union _ _) = True
582 Notice the difference between
583 * NoDoc (no documents)
584 * Empty (one empty document; no height and no width)
585 * text "" (a document containing the empty string;
586 one line high, but has no width)
590 *********************************************************
592 \subsection{@empty@, @text@, @nest@, @union@}
594 *********************************************************
602 char c = textBeside_ (Chr c) 1# Empty
603 text s = case length s of {IBOX(sl) -> textBeside_ (Str s) sl Empty}
604 ftext s = case lengthFS s of {IBOX(sl) -> textBeside_ (PStr s) sl Empty}
605 ptext (Ptr s) = case strLength (Ptr s) of {IBOX(sl) -> textBeside_ (LStr s sl) sl Empty}
607 -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
608 -- intermediate packing/unpacking of the string.
610 "text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
613 nest IBOX(k) p = mkNest k (reduceDoc p) -- Externally callable version
615 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
616 mkNest k (Nest k1 p) = mkNest (k PLUS k1) p
617 mkNest k NoDoc = NoDoc
618 mkNest k Empty = Empty
619 mkNest ILIT(0) p = p -- Worth a try!
620 mkNest k p = nest_ k p
622 -- mkUnion checks for an empty document
623 mkUnion Empty q = Empty
624 mkUnion p q = p `union_` q
627 *********************************************************
629 \subsection{Vertical composition @$$@}
631 *********************************************************
635 p $$ q = Above p False q
636 p $+$ q = Above p True q
638 above :: Doc -> Bool -> RDoc -> RDoc
639 above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
640 above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g ILIT(0) (reduceDoc q)
641 above p g q = aboveNest p g ILIT(0) (reduceDoc q)
643 aboveNest :: RDoc -> Bool -> INT -> RDoc -> RDoc
644 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
646 aboveNest NoDoc g k q = NoDoc
647 aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
650 aboveNest Empty g k q = mkNest k q
651 aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k MINUS k1) q)
652 -- p can't be Empty, so no need for mkNest
654 aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
655 aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
659 Empty -> nilAboveNest g k1 q
660 other -> aboveNest p g k1 q
664 nilAboveNest :: Bool -> INT -> RDoc -> RDoc
665 -- Specification: text s <> nilaboveNest g k q
666 -- = text s <> (text "" $g$ nest k q)
668 nilAboveNest g k Empty = Empty -- Here's why the "text s <>" is in the spec!
669 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k PLUS k1) q
671 nilAboveNest g k q | (not g) && (k GR ILIT(0)) -- No newline if no overlap
672 = textBeside_ (Str (spaces k)) k q
673 | otherwise -- Put them really above
674 = nilAbove_ (mkNest k q)
678 *********************************************************
680 \subsection{Horizontal composition @<>@}
682 *********************************************************
685 p <> q = Beside p False q
686 p <+> q = Beside p True q
688 beside :: Doc -> Bool -> RDoc -> RDoc
689 -- Specification: beside g p q = p <g> q
691 beside NoDoc g q = NoDoc
692 beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q)
694 beside (Nest k p) g q = nest_ k $! beside p g q -- p non-empty
695 beside p@(Beside p1 g1 q1) g2 q2
696 {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2
697 [ && (op1 == <> || op1 == <+>) ] -}
698 | g1 == g2 = beside p1 g1 $! beside q1 g2 q2
699 | otherwise = beside (reduceDoc p) g2 q2
700 beside p@(Above _ _ _) g q = let d = reduceDoc p in d `seq` beside d g q
701 beside (NilAbove p) g q = nilAbove_ $! beside p g q
702 beside (TextBeside s sl p) g q = textBeside_ s sl $! rest
705 Empty -> nilBeside g q
706 other -> beside p g q
710 nilBeside :: Bool -> RDoc -> RDoc
711 -- Specification: text "" <> nilBeside g p
714 nilBeside g Empty = Empty -- Hence the text "" in the spec
715 nilBeside g (Nest _ p) = nilBeside g p
716 nilBeside g p | g = textBeside_ space_text ILIT(1) p
720 *********************************************************
722 \subsection{Separate, @sep@, Hughes version}
724 *********************************************************
727 -- Specification: sep ps = oneLiner (hsep ps)
731 sep = sepX True -- Separate with spaces
732 cat = sepX False -- Don't
735 sepX x (p:ps) = sep1 x (reduceDoc p) ILIT(0) ps
738 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
739 -- = oneLiner (x <g> nest k (hsep ys))
740 -- `union` x $$ nest k (vcat ys)
742 sep1 :: Bool -> RDoc -> INT -> [Doc] -> RDoc
743 sep1 g NoDoc k ys = NoDoc
744 sep1 g (p `Union` q) k ys = sep1 g p k ys
746 (aboveNest q False k (reduceDoc (vcat ys)))
748 sep1 g Empty k ys = mkNest k (sepX g ys)
749 sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k MINUS n) ys)
751 sep1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
752 sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k MINUS sl) ys)
754 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
755 -- Called when we have already found some text in the first item
756 -- We have to eat up nests
758 sepNB g (Nest _ p) k ys = sepNB g p k ys
760 sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))
762 nilAboveNest False k (reduceDoc (vcat ys))
765 | otherwise = hcat ys
767 sepNB g p k ys = sep1 g p k ys
770 *********************************************************
774 *********************************************************
783 -- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
784 -- (fill (oneLiner p2 : ps))
789 fill g (p:ps) = fill1 g (reduceDoc p) ILIT(0) ps
792 fill1 :: Bool -> RDoc -> INT -> [Doc] -> Doc
793 fill1 g NoDoc k ys = NoDoc
794 fill1 g (p `Union` q) k ys = fill1 g p k ys
796 (aboveNest q False k (fill g ys))
798 fill1 g Empty k ys = mkNest k (fill g ys)
799 fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k MINUS n) ys)
801 fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
802 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k MINUS sl) ys)
804 fillNB g (Nest _ p) k ys = fillNB g p k ys
805 fillNB g Empty k [] = Empty
806 fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
808 nilAboveNest False k (fill g (y:ys))
810 k1 | g = k MINUS ILIT(1)
813 fillNB g p k ys = fill1 g p k ys
817 *********************************************************
819 \subsection{Selecting the best layout}
821 *********************************************************
824 best :: Int -- Line length
825 -> Int -- Ribbon length
827 -> RDoc -- No unions in here!
829 best IBOX(w) IBOX(r) p
832 get :: INT -- (Remaining) width of line
836 get w (NilAbove p) = nilAbove_ (get w p)
837 get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
838 get w (Nest k p) = nest_ k (get (w MINUS k) p)
839 get w (p `Union` q) = nicest w r (get w p) (get w q)
841 get1 :: INT -- (Remaining) width of line
842 -> INT -- Amount of first line already eaten up
843 -> Doc -- This is an argument to TextBeside => eat Nests
844 -> Doc -- No unions in here!
846 get1 w sl Empty = Empty
847 get1 w sl NoDoc = NoDoc
848 get1 w sl (NilAbove p) = nilAbove_ (get (w MINUS sl) p)
849 get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl PLUS tl) p)
850 get1 w sl (Nest k p) = get1 w sl p
851 get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
854 nicest w r p q = nicest1 w r ILIT(0) p q
855 nicest1 w r sl p q | fits ((w `minn` r) MINUS sl) p = p
858 fits :: INT -- Space available
860 -> Bool -- True if *first line* of Doc fits in space available
862 fits n p | n LT ILIT(0) = False
865 fits n (NilAbove _) = True
866 fits n (TextBeside _ sl p) = fits (n MINUS sl) p
868 minn x y | x LT y = x
872 @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
873 @first@ returns its first argument if it is non-empty, otherwise its second.
876 first p q | nonEmptySet p = p
879 nonEmptySet NoDoc = False
880 nonEmptySet (p `Union` q) = True
881 nonEmptySet Empty = True
882 nonEmptySet (NilAbove p) = True -- NoDoc always in first line
883 nonEmptySet (TextBeside _ _ p) = nonEmptySet p
884 nonEmptySet (Nest _ p) = nonEmptySet p
887 @oneLiner@ returns the one-line members of the given set of @Doc@s.
890 oneLiner :: Doc -> Doc
891 oneLiner NoDoc = NoDoc
892 oneLiner Empty = Empty
893 oneLiner (NilAbove p) = NoDoc
894 oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
895 oneLiner (Nest k p) = nest_ k (oneLiner p)
896 oneLiner (p `Union` q) = oneLiner p
901 *********************************************************
903 \subsection{Displaying the best layout}
905 *********************************************************
910 renderStyle Style{mode, lineLength, ribbonsPerLine} doc
911 = fullRender mode lineLength ribbonsPerLine doc ""
914 render doc = showDocWith PageMode doc
915 showDoc doc rest = showDocWithAppend PageMode doc rest
917 showDocWithAppend :: Mode -> Doc -> String -> String
918 showDocWithAppend mode doc rest = fullRender mode 100 1.5 string_txt rest doc
920 showDocWith :: Mode -> Doc -> String
921 showDocWith mode doc = showDocWithAppend mode doc ""
923 string_txt (Chr c) s = c:s
924 string_txt (Str s1) s2 = s1 ++ s2
925 string_txt (PStr s1) s2 = unpackFS s1 ++ s2
926 string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
928 unpackLitString addr =
932 | ch `eqChar#` '\0'# = []
933 | otherwise = C# ch : unpack (nh +# 1#)
935 ch = indexCharOffAddr# addr nh
940 fullRender OneLineMode _ _ txt end doc
941 = lay (reduceDoc doc)
943 lay NoDoc = cant_fail
944 lay (Union p q) = (lay q) -- Second arg can't be NoDoc
945 lay (Nest k p) = lay p
947 lay (NilAbove p) = space_text `txt` lay p -- NoDoc always on first line
948 lay (TextBeside s sl p) = s `txt` lay p
950 fullRender LeftMode _ _ txt end doc
951 = lay (reduceDoc doc)
953 lay NoDoc = cant_fail
954 lay (Union p q) = lay (first p q)
955 lay (Nest k p) = lay p
957 lay (NilAbove p) = nl_text `txt` lay p -- NoDoc always on first line
958 lay (TextBeside s sl p) = s `txt` lay p
960 fullRender mode line_length ribbons_per_line txt end doc
961 = display mode line_length ribbon_length txt end best_doc
963 best_doc = best hacked_line_length ribbon_length (reduceDoc doc)
965 hacked_line_length, ribbon_length :: Int
966 ribbon_length = round (fromIntegral line_length / ribbons_per_line)
967 hacked_line_length = case mode of { ZigZagMode -> MAXINT; other -> line_length }
969 display mode IBOX(page_width) IBOX(ribbon_width) txt end doc
970 = case page_width MINUS ribbon_width of { gap_width ->
971 case gap_width DIV ILIT(2) of { shift ->
973 lay k (Nest k1 p) = lay (k PLUS k1) p
976 lay k (NilAbove p) = nl_text `txt` lay k p
978 lay k (TextBeside s sl p)
980 ZigZagMode | k GREQ gap_width
982 Str (multi_ch shift '/') `txt` (
984 lay1 (k MINUS shift) s sl p)))
988 Str (multi_ch shift '\\') `txt` (
990 lay1 (k PLUS shift) s sl p )))
992 other -> lay1 k s sl p
994 lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k PLUS sl) p)
996 lay2 k (NilAbove p) = nl_text `txt` lay k p
997 lay2 k (TextBeside s sl p) = s `txt` (lay2 (k PLUS sl) p)
998 lay2 k (Nest _ p) = lay2 k p
1004 cant_fail = error "easy_display: NoDoc"
1006 indent n | n GREQ ILIT(8) = '\t' : indent (n MINUS ILIT(8))
1007 | otherwise = spaces n
1009 multi_ch ILIT(0) ch = ""
1010 multi_ch n ch = ch : multi_ch (n MINUS ILIT(1)) ch
1013 spaces n = ' ' : spaces (n MINUS ILIT(1))
1017 pprCols = (120 :: Int) -- could make configurable
1019 printDoc :: Mode -> Handle -> Doc -> IO ()
1020 printDoc LeftMode hdl doc
1021 = do { printLeftRender hdl doc; hFlush hdl }
1022 printDoc mode hdl doc
1023 = do { fullRender mode pprCols 1.5 put done doc ;
1026 put (Chr c) next = hPutChar hdl c >> next
1027 put (Str s) next = hPutStr hdl s >> next
1028 put (PStr s) next = hPutFS hdl s >> next
1029 put (LStr s l) next = hPutLitString hdl s l >> next
1031 done = hPutChar hdl '\n'
1033 -- some versions of hPutBuf will barf if the length is zero
1034 hPutLitString handle a# 0# = return ()
1035 hPutLitString handle a# l#
1036 #if __GLASGOW_HASKELL__ < 411
1037 = hPutBuf handle (A# a#) (I# l#)
1039 = hPutBuf handle (Ptr a#) (I# l#)
1042 -- Printing output in LeftMode is performance critical: it's used when
1043 -- dumping C and assembly output, so we allow ourselves a few dirty
1046 -- (1) we specialise fullRender for LeftMode with IO output.
1048 -- (2) we add a layer of buffering on top of Handles. Handles
1049 -- don't perform well with lots of hPutChars, which is mostly
1050 -- what we're doing here, because Handles have to be thread-safe
1051 -- and async exception-safe. We only have a single thread and don't
1052 -- care about exceptions, so we add a layer of fast buffering
1053 -- over the Handle interface.
1055 -- (3) a few hacks in layLeft below to convince GHC to generate the right
1058 printLeftRender :: Handle -> Doc -> IO ()
1059 printLeftRender hdl doc = do
1060 b <- newBufHandle hdl
1061 layLeft b (reduceDoc doc)
1064 -- HACK ALERT! the "return () >>" below convinces GHC to eta-expand
1065 -- this function with the IO state lambda. Otherwise we end up with
1066 -- closures in all the case branches.
1067 layLeft b _ | b `seq` False = undefined -- make it strict in b
1068 layLeft b NoDoc = cant_fail
1069 layLeft b (Union p q) = return () >> layLeft b (first p q)
1070 layLeft b (Nest k p) = return () >> layLeft b p
1071 layLeft b Empty = bPutChar b '\n'
1072 layLeft b (NilAbove p) = bPutChar b '\n' >> layLeft b p
1073 layLeft b (TextBeside s sl p) = put b s >> layLeft b p
1075 put b _ | b `seq` False = undefined
1076 put b (Chr c) = bPutChar b c
1077 put b (Str s) = bPutStr b s
1078 put b (PStr s) = bPutFS b s
1079 put b (LStr s l) = bPutLitString b s l
1081 #if __GLASGOW_HASKELL__ < 503
1082 hPutBuf = hPutBufFull