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"
185 import Numeric (fromRat)
188 import System.IO ( hPutBuf )
190 import GHC.Base ( unpackCString# )
191 import GHC.Ptr ( Ptr(..) )
193 -- Don't import Util( assertPanic ) because it makes a loop in the module structure
202 *********************************************************
204 \subsection{CPP magic so that we can compile with both GHC and Hugs}
206 *********************************************************
208 The library uses unboxed types to get a bit more speed, but these CPP macros
209 allow you to use either GHC or Hugs. To get GHC, just set the CPP variable
214 #if defined(__GLASGOW_HASKELL__)
218 -- Disable ASSERT checks; they are expensive!
219 #define LOCAL_ASSERT(x)
222 #define IBOX(x) (I# (x))
225 #define NEGATE negateInt#
230 #define DIV `quotInt#`
234 #define MAXINT maxBound
240 #define LOCAL_ASSERT(x)
245 #define NEGATE negate
254 #define MAXINT maxBound
261 *********************************************************
263 \subsection{The interface}
265 *********************************************************
267 The primitive @Doc@ values
271 isEmpty :: Doc -> Bool
272 text :: String -> Doc
275 semi, comma, colon, space, equals :: Doc
276 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
278 parens, brackets, braces :: Doc -> Doc
279 quotes, doubleQuotes :: Doc -> Doc
282 integer :: Integer -> Doc
283 float :: Float -> Doc
284 double :: Double -> Doc
285 rational :: Rational -> Doc
288 Combining @Doc@ values
291 (<>) :: Doc -> Doc -> Doc -- Beside
292 hcat :: [Doc] -> Doc -- List version of <>
293 (<+>) :: Doc -> Doc -> Doc -- Beside, separated by space
294 hsep :: [Doc] -> Doc -- List version of <+>
296 ($$) :: Doc -> Doc -> Doc -- Above; if there is no
297 -- overlap it "dovetails" the two
298 vcat :: [Doc] -> Doc -- List version of $$
300 cat :: [Doc] -> Doc -- Either hcat or vcat
301 sep :: [Doc] -> Doc -- Either hsep or vcat
302 fcat :: [Doc] -> Doc -- ``Paragraph fill'' version of cat
303 fsep :: [Doc] -> Doc -- ``Paragraph fill'' version of sep
305 nest :: Int -> Doc -> Doc -- Nested
311 hang :: Doc -> Int -> Doc -> Doc
312 punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
315 Displaying @Doc@ values.
318 instance SHOW Doc where
319 showsPrec prec doc cont = showDoc doc cont
321 render :: Doc -> String -- Uses default style
323 -> Int -- Line length
324 -> Float -- Ribbons per line
325 -> (TextDetails -> a -> a) -- What to do with text
326 -> a -- What to do at the end
330 {- When we start using 1.3
331 renderStyle :: Style -> Doc -> String
332 data Style = Style { lineLength :: Int, -- In chars
333 ribbonsPerLine :: Float, -- Ratio of ribbon length to line length
336 style :: Style -- The default style
337 style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
340 data Mode = PageMode -- Normal
341 | ZigZagMode -- With zig-zag cuts
342 | LeftMode -- No indentation, infinitely long lines
343 | OneLineMode -- All on one line
348 *********************************************************
350 \subsection{The @Doc@ calculus}
352 *********************************************************
354 The @Doc@ combinators satisfy the following laws:
358 <a1> (x $$ y) $$ z = x $$ (y $$ z)
366 <b1> (x <> y) <> z = x <> (y <> z)
367 <b2> empty <> x = empty
374 <t1> text s <> text t = text (s++t)
375 <t2> text "" <> x = x, if x non-empty
380 <n2> nest k (nest k' x) = nest (k+k') x
381 <n3> nest k (x <> y) = nest k z <> nest k y
382 <n4> nest k (x $$ y) = nest k x $$ nest k y
383 <n5> nest k empty = empty
384 <n6> x <> nest k y = x <> y, if x non-empty
386 ** Note the side condition on <n6>! It is this that
387 ** makes it OK for empty to be a left unit for <>.
391 <m1> (text s <> x) $$ y = text s <> ((text "" <> x)) $$
394 <m2> (x $$ y) <> z = x $$ (y <> z)
398 Laws for list versions
399 ~~~~~~~~~~~~~~~~~~~~~~
400 <l1> sep (ps++[empty]++qs) = sep (ps ++ qs)
401 ...ditto hsep, hcat, vcat, fill...
403 <l2> nest k (sep ps) = sep (map (nest k) ps)
404 ...ditto hsep, hcat, vcat, fill...
408 <o1> oneLiner (nest k p) = nest k (oneLiner p)
409 <o2> oneLiner (x <> y) = oneLiner x <> oneLiner y
413 You might think that the following verion of <m1> would
416 <3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$
419 But it doesn't work, for if x=empty, we would have
421 text s $$ y = text s <> (empty $$ nest (-length s) y)
422 = text s <> nest (-length s) y
427 *********************************************************
429 \subsection{Simple derived definitions}
431 *********************************************************
446 int n = text (show n)
447 integer n = text (show n)
448 float n = text (show n)
449 double n = text (show n)
450 rational n = text (show (fromRat n))
451 --rational n = text (show (fromRationalX n)) -- _showRational 30 n)
453 quotes p = char '`' <> p <> char '\''
454 doubleQuotes p = char '"' <> p <> char '"'
455 parens p = char '(' <> p <> char ')'
456 brackets p = char '[' <> p <> char ']'
457 braces p = char '{' <> p <> char '}'
460 hcat = foldr (<>) empty
461 hsep = foldr (<+>) empty
462 vcat = foldr ($$) empty
464 hang d1 n d2 = sep [d1, nest n d2]
467 punctuate p (d:ds) = go d ds
470 go d (e:es) = (d <> p) : go e es
474 *********************************************************
476 \subsection{The @Doc@ data type}
478 *********************************************************
480 A @Doc@ represents a {\em set} of layouts. A @Doc@ with
481 no occurrences of @Union@ or @NoDoc@ represents just one layout.
485 | NilAbove Doc -- text "" $$ x
486 | TextBeside !TextDetails INT Doc -- text s <> x
487 | Nest INT Doc -- nest k x
488 | Union Doc Doc -- ul `union` ur
489 | NoDoc -- The empty set of documents
490 | Beside Doc Bool Doc -- True <=> space between
491 | Above Doc Bool Doc -- True <=> never overlap
493 type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
496 reduceDoc :: Doc -> RDoc
497 reduceDoc (Beside p g q) = beside p g (reduceDoc q)
498 reduceDoc (Above p g q) = above p g (reduceDoc q)
502 data TextDetails = Chr {-#UNPACK#-}!Char
504 | PStr FastString -- a hashed string
505 | LStr Addr# Int# -- a '\0'-terminated array of bytes
511 Here are the invariants:
514 The argument of @NilAbove@ is never @Empty@. Therefore
515 a @NilAbove@ occupies at least two lines.
518 The arugment of @TextBeside@ is never @Nest@.
521 The layouts of the two arguments of @Union@ both flatten to the same string.
524 The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
527 The right argument of a union cannot be equivalent to the empty set (@NoDoc@).
528 If the left argument of a union is equivalent to the empty set (@NoDoc@),
529 then the @NoDoc@ appears in the first line.
532 An empty document is always represented by @Empty@.
533 It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.
536 The first line of every layout in the left argument of @Union@
537 is longer than the first line of any layout in the right argument.
538 (1) ensures that the left argument has a first line. In view of (3),
539 this invariant means that the right argument must have at least two
544 -- Arg of a NilAbove is always an RDoc
545 nilAbove_ p = LOCAL_ASSERT( ok p ) NilAbove p
550 -- Arg of a TextBeside is always an RDoc
551 textBeside_ s sl p = TextBeside s sl (LOCAL_ASSERT( ok p ) p)
553 ok (Nest _ _) = False
556 -- Arg of Nest is always an RDoc
557 nest_ k p = Nest k (LOCAL_ASSERT( ok p ) p)
562 -- Args of union are always RDocs
563 union_ p q = Union (LOCAL_ASSERT( ok p ) p) (LOCAL_ASSERT( ok q ) q)
565 ok (TextBeside _ _ _) = True
566 ok (NilAbove _) = True
567 ok (Union _ _) = True
572 Notice the difference between
573 * NoDoc (no documents)
574 * Empty (one empty document; no height and no width)
575 * text "" (a document containing the empty string;
576 one line high, but has no width)
580 *********************************************************
582 \subsection{@empty@, @text@, @nest@, @union@}
584 *********************************************************
592 char c = textBeside_ (Chr c) 1# Empty
593 text s = case length s of {IBOX(sl) -> textBeside_ (Str s) sl Empty}
594 ftext s = case lengthFS s of {IBOX(sl) -> textBeside_ (PStr s) sl Empty}
595 ptext (Ptr s) = case strLength (Ptr s) of {IBOX(sl) -> textBeside_ (LStr s sl) sl Empty}
597 -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
598 -- intermediate packing/unpacking of the string.
600 "text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
603 nest IBOX(k) p = mkNest k (reduceDoc p) -- Externally callable version
605 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
606 mkNest k (Nest k1 p) = mkNest (k PLUS k1) p
607 mkNest k NoDoc = NoDoc
608 mkNest k Empty = Empty
609 mkNest ILIT(0) p = p -- Worth a try!
610 mkNest k p = nest_ k p
612 -- mkUnion checks for an empty document
613 mkUnion Empty q = Empty
614 mkUnion p q = p `union_` q
617 *********************************************************
619 \subsection{Vertical composition @$$@}
621 *********************************************************
625 p $$ q = Above p False q
626 p $+$ q = Above p True q
628 above :: Doc -> Bool -> RDoc -> RDoc
629 above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
630 above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g ILIT(0) (reduceDoc q)
631 above p g q = aboveNest p g ILIT(0) (reduceDoc q)
633 aboveNest :: RDoc -> Bool -> INT -> RDoc -> RDoc
634 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
636 aboveNest NoDoc g k q = NoDoc
637 aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
640 aboveNest Empty g k q = mkNest k q
641 aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k MINUS k1) q)
642 -- p can't be Empty, so no need for mkNest
644 aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
645 aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
649 Empty -> nilAboveNest g k1 q
650 other -> aboveNest p g k1 q
654 nilAboveNest :: Bool -> INT -> RDoc -> RDoc
655 -- Specification: text s <> nilaboveNest g k q
656 -- = text s <> (text "" $g$ nest k q)
658 nilAboveNest g k Empty = Empty -- Here's why the "text s <>" is in the spec!
659 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k PLUS k1) q
661 nilAboveNest g k q | (not g) && (k GR ILIT(0)) -- No newline if no overlap
662 = textBeside_ (Str (spaces k)) k q
663 | otherwise -- Put them really above
664 = nilAbove_ (mkNest k q)
668 *********************************************************
670 \subsection{Horizontal composition @<>@}
672 *********************************************************
675 p <> q = Beside p False q
676 p <+> q = Beside p True q
678 beside :: Doc -> Bool -> RDoc -> RDoc
679 -- Specification: beside g p q = p <g> q
681 beside NoDoc g q = NoDoc
682 beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q)
684 beside (Nest k p) g q = nest_ k $! beside p g q -- p non-empty
685 beside p@(Beside p1 g1 q1) g2 q2
686 {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2
687 [ && (op1 == <> || op1 == <+>) ] -}
688 | g1 == g2 = beside p1 g1 $! beside q1 g2 q2
689 | otherwise = beside (reduceDoc p) g2 q2
690 beside p@(Above _ _ _) g q = let d = reduceDoc p in d `seq` beside d g q
691 beside (NilAbove p) g q = nilAbove_ $! beside p g q
692 beside (TextBeside s sl p) g q = textBeside_ s sl $! rest
695 Empty -> nilBeside g q
696 other -> beside p g q
700 nilBeside :: Bool -> RDoc -> RDoc
701 -- Specification: text "" <> nilBeside g p
704 nilBeside g Empty = Empty -- Hence the text "" in the spec
705 nilBeside g (Nest _ p) = nilBeside g p
706 nilBeside g p | g = textBeside_ space_text ILIT(1) p
710 *********************************************************
712 \subsection{Separate, @sep@, Hughes version}
714 *********************************************************
717 -- Specification: sep ps = oneLiner (hsep ps)
721 sep = sepX True -- Separate with spaces
722 cat = sepX False -- Don't
725 sepX x (p:ps) = sep1 x (reduceDoc p) ILIT(0) ps
728 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
729 -- = oneLiner (x <g> nest k (hsep ys))
730 -- `union` x $$ nest k (vcat ys)
732 sep1 :: Bool -> RDoc -> INT -> [Doc] -> RDoc
733 sep1 g NoDoc k ys = NoDoc
734 sep1 g (p `Union` q) k ys = sep1 g p k ys
736 (aboveNest q False k (reduceDoc (vcat ys)))
738 sep1 g Empty k ys = mkNest k (sepX g ys)
739 sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k MINUS n) ys)
741 sep1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
742 sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k MINUS sl) ys)
744 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
745 -- Called when we have already found some text in the first item
746 -- We have to eat up nests
748 sepNB g (Nest _ p) k ys = sepNB g p k ys
750 sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))
752 nilAboveNest False k (reduceDoc (vcat ys))
755 | otherwise = hcat ys
757 sepNB g p k ys = sep1 g p k ys
760 *********************************************************
764 *********************************************************
773 -- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
774 -- (fill (oneLiner p2 : ps))
779 fill g (p:ps) = fill1 g (reduceDoc p) ILIT(0) ps
782 fill1 :: Bool -> RDoc -> INT -> [Doc] -> Doc
783 fill1 g NoDoc k ys = NoDoc
784 fill1 g (p `Union` q) k ys = fill1 g p k ys
786 (aboveNest q False k (fill g ys))
788 fill1 g Empty k ys = mkNest k (fill g ys)
789 fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k MINUS n) ys)
791 fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
792 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k MINUS sl) ys)
794 fillNB g (Nest _ p) k ys = fillNB g p k ys
795 fillNB g Empty k [] = Empty
796 fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
798 nilAboveNest False k (fill g (y:ys))
800 k1 | g = k MINUS ILIT(1)
803 fillNB g p k ys = fill1 g p k ys
807 *********************************************************
809 \subsection{Selecting the best layout}
811 *********************************************************
814 best :: Int -- Line length
815 -> Int -- Ribbon length
817 -> RDoc -- No unions in here!
819 best IBOX(w) IBOX(r) p
822 get :: INT -- (Remaining) width of line
826 get w (NilAbove p) = nilAbove_ (get w p)
827 get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
828 get w (Nest k p) = nest_ k (get (w MINUS k) p)
829 get w (p `Union` q) = nicest w r (get w p) (get w q)
831 get1 :: INT -- (Remaining) width of line
832 -> INT -- Amount of first line already eaten up
833 -> Doc -- This is an argument to TextBeside => eat Nests
834 -> Doc -- No unions in here!
836 get1 w sl Empty = Empty
837 get1 w sl NoDoc = NoDoc
838 get1 w sl (NilAbove p) = nilAbove_ (get (w MINUS sl) p)
839 get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl PLUS tl) p)
840 get1 w sl (Nest k p) = get1 w sl p
841 get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
844 nicest w r p q = nicest1 w r ILIT(0) p q
845 nicest1 w r sl p q | fits ((w `minn` r) MINUS sl) p = p
848 fits :: INT -- Space available
850 -> Bool -- True if *first line* of Doc fits in space available
852 fits n p | n LT ILIT(0) = False
855 fits n (NilAbove _) = True
856 fits n (TextBeside _ sl p) = fits (n MINUS sl) p
858 minn x y | x LT y = x
862 @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
863 @first@ returns its first argument if it is non-empty, otherwise its second.
866 first p q | nonEmptySet p = p
869 nonEmptySet NoDoc = False
870 nonEmptySet (p `Union` q) = True
871 nonEmptySet Empty = True
872 nonEmptySet (NilAbove p) = True -- NoDoc always in first line
873 nonEmptySet (TextBeside _ _ p) = nonEmptySet p
874 nonEmptySet (Nest _ p) = nonEmptySet p
877 @oneLiner@ returns the one-line members of the given set of @Doc@s.
880 oneLiner :: Doc -> Doc
881 oneLiner NoDoc = NoDoc
882 oneLiner Empty = Empty
883 oneLiner (NilAbove p) = NoDoc
884 oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
885 oneLiner (Nest k p) = nest_ k (oneLiner p)
886 oneLiner (p `Union` q) = oneLiner p
891 *********************************************************
893 \subsection{Displaying the best layout}
895 *********************************************************
900 renderStyle Style{mode, lineLength, ribbonsPerLine} doc
901 = fullRender mode lineLength ribbonsPerLine doc ""
904 render doc = showDocWith PageMode doc
905 showDoc doc rest = showDocWithAppend PageMode doc rest
907 showDocWithAppend :: Mode -> Doc -> String -> String
908 showDocWithAppend mode doc rest = fullRender mode 100 1.5 string_txt rest doc
910 showDocWith :: Mode -> Doc -> String
911 showDocWith mode doc = showDocWithAppend mode doc ""
913 string_txt (Chr c) s = c:s
914 string_txt (Str s1) s2 = s1 ++ s2
915 string_txt (PStr s1) s2 = unpackFS s1 ++ s2
916 string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
918 unpackLitString addr =
922 | ch `eqChar#` '\0'# = []
923 | otherwise = C# ch : unpack (nh +# 1#)
925 ch = indexCharOffAddr# addr nh
930 fullRender OneLineMode _ _ txt end doc
931 = lay (reduceDoc doc)
933 lay NoDoc = cant_fail
934 lay (Union p q) = (lay q) -- Second arg can't be NoDoc
935 lay (Nest k p) = lay p
937 lay (NilAbove p) = space_text `txt` lay p -- NoDoc always on first line
938 lay (TextBeside s sl p) = s `txt` lay p
940 fullRender LeftMode _ _ txt end doc
941 = lay (reduceDoc doc)
943 lay NoDoc = cant_fail
944 lay (Union p q) = lay (first p q)
945 lay (Nest k p) = lay p
947 lay (NilAbove p) = nl_text `txt` lay p -- NoDoc always on first line
948 lay (TextBeside s sl p) = s `txt` lay p
950 fullRender mode line_length ribbons_per_line txt end doc
951 = display mode line_length ribbon_length txt end best_doc
953 best_doc = best hacked_line_length ribbon_length (reduceDoc doc)
955 hacked_line_length, ribbon_length :: Int
956 ribbon_length = round (fromIntegral line_length / ribbons_per_line)
957 hacked_line_length = case mode of { ZigZagMode -> MAXINT; other -> line_length }
959 display mode IBOX(page_width) IBOX(ribbon_width) txt end doc
960 = case page_width MINUS ribbon_width of { gap_width ->
961 case gap_width DIV ILIT(2) of { shift ->
963 lay k (Nest k1 p) = lay (k PLUS k1) p
966 lay k (NilAbove p) = nl_text `txt` lay k p
968 lay k (TextBeside s sl p)
970 ZigZagMode | k GREQ gap_width
972 Str (multi_ch shift '/') `txt` (
974 lay1 (k MINUS shift) s sl p)))
978 Str (multi_ch shift '\\') `txt` (
980 lay1 (k PLUS shift) s sl p )))
982 other -> lay1 k s sl p
984 lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k PLUS sl) p)
986 lay2 k (NilAbove p) = nl_text `txt` lay k p
987 lay2 k (TextBeside s sl p) = s `txt` (lay2 (k PLUS sl) p)
988 lay2 k (Nest _ p) = lay2 k p
994 cant_fail = error "easy_display: NoDoc"
996 indent n | n GREQ ILIT(8) = '\t' : indent (n MINUS ILIT(8))
997 | otherwise = spaces n
999 multi_ch ILIT(0) ch = ""
1000 multi_ch n ch = ch : multi_ch (n MINUS ILIT(1)) ch
1003 spaces n = ' ' : spaces (n MINUS ILIT(1))
1007 pprCols = (120 :: Int) -- could make configurable
1009 printDoc :: Mode -> Handle -> Doc -> IO ()
1010 printDoc LeftMode hdl doc
1011 = do { printLeftRender hdl doc; hFlush hdl }
1012 printDoc mode hdl doc
1013 = do { fullRender mode pprCols 1.5 put done doc ;
1016 put (Chr c) next = hPutChar hdl c >> next
1017 put (Str s) next = hPutStr hdl s >> next
1018 put (PStr s) next = hPutFS hdl s >> next
1019 put (LStr s l) next = hPutLitString hdl s l >> next
1021 done = hPutChar hdl '\n'
1023 -- some versions of hPutBuf will barf if the length is zero
1024 hPutLitString handle a# 0# = return ()
1025 hPutLitString handle a# l#
1026 #if __GLASGOW_HASKELL__ < 411
1027 = hPutBuf handle (A# a#) (I# l#)
1029 = hPutBuf handle (Ptr a#) (I# l#)
1032 -- Printing output in LeftMode is performance critical: it's used when
1033 -- dumping C and assembly output, so we allow ourselves a few dirty
1036 -- (1) we specialise fullRender for LeftMode with IO output.
1038 -- (2) we add a layer of buffering on top of Handles. Handles
1039 -- don't perform well with lots of hPutChars, which is mostly
1040 -- what we're doing here, because Handles have to be thread-safe
1041 -- and async exception-safe. We only have a single thread and don't
1042 -- care about exceptions, so we add a layer of fast buffering
1043 -- over the Handle interface.
1045 -- (3) a few hacks in layLeft below to convince GHC to generate the right
1048 printLeftRender :: Handle -> Doc -> IO ()
1049 printLeftRender hdl doc = do
1050 b <- newBufHandle hdl
1051 layLeft b (reduceDoc doc)
1054 -- HACK ALERT! the "return () >>" below convinces GHC to eta-expand
1055 -- this function with the IO state lambda. Otherwise we end up with
1056 -- closures in all the case branches.
1057 layLeft b _ | b `seq` False = undefined -- make it strict in b
1058 layLeft b NoDoc = cant_fail
1059 layLeft b (Union p q) = return () >> layLeft b (first p q)
1060 layLeft b (Nest k p) = return () >> layLeft b p
1061 layLeft b Empty = bPutChar b '\n'
1062 layLeft b (NilAbove p) = bPutChar b '\n' >> layLeft b p
1063 layLeft b (TextBeside s sl p) = put b s >> layLeft b p
1065 put b _ | b `seq` False = undefined
1066 put b (Chr c) = bPutChar b c
1067 put b (Str s) = bPutStr b s
1068 put b (PStr s) = bPutFS b s
1069 put b (LStr s l) = bPutLitString b s l
1071 #if __GLASGOW_HASKELL__ < 503
1072 hPutBuf = hPutBufFull