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 GHC.Base ( unpackCString# )
189 import GHC.Ptr ( Ptr(..) )
191 -- Don't import Util( assertPanic ) because it makes a loop in the module structure
200 *********************************************************
202 \subsection{CPP magic so that we can compile with both GHC and Hugs}
204 *********************************************************
206 The library uses unboxed types to get a bit more speed, but these CPP macros
207 allow you to use either GHC or Hugs. To get GHC, just set the CPP variable
212 #if defined(__GLASGOW_HASKELL__)
216 -- Disable ASSERT checks; they are expensive!
217 #define LOCAL_ASSERT(x)
220 #define IBOX(x) (I# (x))
223 #define NEGATE negateInt#
228 #define DIV `quotInt#`
232 #define MAXINT maxBound
238 #define LOCAL_ASSERT(x)
243 #define NEGATE negate
252 #define MAXINT maxBound
259 *********************************************************
261 \subsection{The interface}
263 *********************************************************
265 The primitive @Doc@ values
269 isEmpty :: Doc -> Bool
270 text :: String -> Doc
273 semi, comma, colon, space, equals :: Doc
274 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
276 parens, brackets, braces :: Doc -> Doc
277 quotes, doubleQuotes :: Doc -> Doc
280 integer :: Integer -> Doc
281 float :: Float -> Doc
282 double :: Double -> Doc
283 rational :: Rational -> Doc
286 Combining @Doc@ values
289 (<>) :: Doc -> Doc -> Doc -- Beside
290 hcat :: [Doc] -> Doc -- List version of <>
291 (<+>) :: Doc -> Doc -> Doc -- Beside, separated by space
292 hsep :: [Doc] -> Doc -- List version of <+>
294 ($$) :: Doc -> Doc -> Doc -- Above; if there is no
295 -- overlap it "dovetails" the two
296 vcat :: [Doc] -> Doc -- List version of $$
298 cat :: [Doc] -> Doc -- Either hcat or vcat
299 sep :: [Doc] -> Doc -- Either hsep or vcat
300 fcat :: [Doc] -> Doc -- ``Paragraph fill'' version of cat
301 fsep :: [Doc] -> Doc -- ``Paragraph fill'' version of sep
303 nest :: Int -> Doc -> Doc -- Nested
309 hang :: Doc -> Int -> Doc -> Doc
310 punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
313 Displaying @Doc@ values.
316 instance SHOW Doc where
317 showsPrec prec doc cont = showDoc doc cont
319 render :: Doc -> String -- Uses default style
321 -> Int -- Line length
322 -> Float -- Ribbons per line
323 -> (TextDetails -> a -> a) -- What to do with text
324 -> a -- What to do at the end
328 {- When we start using 1.3
329 renderStyle :: Style -> Doc -> String
330 data Style = Style { lineLength :: Int, -- In chars
331 ribbonsPerLine :: Float, -- Ratio of ribbon length to line length
334 style :: Style -- The default style
335 style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
338 data Mode = PageMode -- Normal
339 | ZigZagMode -- With zig-zag cuts
340 | LeftMode -- No indentation, infinitely long lines
341 | OneLineMode -- All on one line
346 *********************************************************
348 \subsection{The @Doc@ calculus}
350 *********************************************************
352 The @Doc@ combinators satisfy the following laws:
356 <a1> (x $$ y) $$ z = x $$ (y $$ z)
364 <b1> (x <> y) <> z = x <> (y <> z)
365 <b2> empty <> x = empty
372 <t1> text s <> text t = text (s++t)
373 <t2> text "" <> x = x, if x non-empty
378 <n2> nest k (nest k' x) = nest (k+k') x
379 <n3> nest k (x <> y) = nest k z <> nest k y
380 <n4> nest k (x $$ y) = nest k x $$ nest k y
381 <n5> nest k empty = empty
382 <n6> x <> nest k y = x <> y, if x non-empty
384 ** Note the side condition on <n6>! It is this that
385 ** makes it OK for empty to be a left unit for <>.
389 <m1> (text s <> x) $$ y = text s <> ((text "" <> x)) $$
392 <m2> (x $$ y) <> z = x $$ (y <> z)
396 Laws for list versions
397 ~~~~~~~~~~~~~~~~~~~~~~
398 <l1> sep (ps++[empty]++qs) = sep (ps ++ qs)
399 ...ditto hsep, hcat, vcat, fill...
401 <l2> nest k (sep ps) = sep (map (nest k) ps)
402 ...ditto hsep, hcat, vcat, fill...
406 <o1> oneLiner (nest k p) = nest k (oneLiner p)
407 <o2> oneLiner (x <> y) = oneLiner x <> oneLiner y
411 You might think that the following verion of <m1> would
414 <3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$
417 But it doesn't work, for if x=empty, we would have
419 text s $$ y = text s <> (empty $$ nest (-length s) y)
420 = text s <> nest (-length s) y
425 *********************************************************
427 \subsection{Simple derived definitions}
429 *********************************************************
444 int n = text (show n)
445 integer n = text (show n)
446 float n = text (show n)
447 double n = text (show n)
448 rational n = text (show (fromRat n))
449 --rational n = text (show (fromRationalX n)) -- _showRational 30 n)
451 quotes p = char '`' <> p <> char '\''
452 doubleQuotes p = char '"' <> p <> char '"'
453 parens p = char '(' <> p <> char ')'
454 brackets p = char '[' <> p <> char ']'
455 braces p = char '{' <> p <> char '}'
458 hcat = foldr (<>) empty
459 hsep = foldr (<+>) empty
460 vcat = foldr ($$) empty
462 hang d1 n d2 = sep [d1, nest n d2]
465 punctuate p (d:ds) = go d ds
468 go d (e:es) = (d <> p) : go e es
472 *********************************************************
474 \subsection{The @Doc@ data type}
476 *********************************************************
478 A @Doc@ represents a {\em set} of layouts. A @Doc@ with
479 no occurrences of @Union@ or @NoDoc@ represents just one layout.
483 | NilAbove Doc -- text "" $$ x
484 | TextBeside !TextDetails INT Doc -- text s <> x
485 | Nest INT Doc -- nest k x
486 | Union Doc Doc -- ul `union` ur
487 | NoDoc -- The empty set of documents
488 | Beside Doc Bool Doc -- True <=> space between
489 | Above Doc Bool Doc -- True <=> never overlap
491 type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
494 reduceDoc :: Doc -> RDoc
495 reduceDoc (Beside p g q) = beside p g (reduceDoc q)
496 reduceDoc (Above p g q) = above p g (reduceDoc q)
500 data TextDetails = Chr {-#UNPACK#-}!Char
502 | PStr FastString -- a hashed string
503 | LStr Addr# Int# -- a '\0'-terminated array of bytes
509 Here are the invariants:
512 The argument of @NilAbove@ is never @Empty@. Therefore
513 a @NilAbove@ occupies at least two lines.
516 The arugment of @TextBeside@ is never @Nest@.
519 The layouts of the two arguments of @Union@ both flatten to the same string.
522 The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
525 The right argument of a union cannot be equivalent to the empty set (@NoDoc@).
526 If the left argument of a union is equivalent to the empty set (@NoDoc@),
527 then the @NoDoc@ appears in the first line.
530 An empty document is always represented by @Empty@.
531 It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.
534 The first line of every layout in the left argument of @Union@
535 is longer than the first line of any layout in the right argument.
536 (1) ensures that the left argument has a first line. In view of (3),
537 this invariant means that the right argument must have at least two
542 -- Arg of a NilAbove is always an RDoc
543 nilAbove_ p = LOCAL_ASSERT( ok p ) NilAbove p
548 -- Arg of a TextBeside is always an RDoc
549 textBeside_ s sl p = TextBeside s sl (LOCAL_ASSERT( ok p ) p)
551 ok (Nest _ _) = False
554 -- Arg of Nest is always an RDoc
555 nest_ k p = Nest k (LOCAL_ASSERT( ok p ) p)
560 -- Args of union are always RDocs
561 union_ p q = Union (LOCAL_ASSERT( ok p ) p) (LOCAL_ASSERT( ok q ) q)
563 ok (TextBeside _ _ _) = True
564 ok (NilAbove _) = True
565 ok (Union _ _) = True
570 Notice the difference between
571 * NoDoc (no documents)
572 * Empty (one empty document; no height and no width)
573 * text "" (a document containing the empty string;
574 one line high, but has no width)
578 *********************************************************
580 \subsection{@empty@, @text@, @nest@, @union@}
582 *********************************************************
590 char c = textBeside_ (Chr c) 1# Empty
591 text s = case length s of {IBOX(sl) -> textBeside_ (Str s) sl Empty}
592 ftext s = case lengthFS s of {IBOX(sl) -> textBeside_ (PStr s) sl Empty}
593 ptext (Ptr s) = case strLength (Ptr s) of {IBOX(sl) -> textBeside_ (LStr s sl) sl Empty}
595 -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
596 -- intermediate packing/unpacking of the string.
598 "text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
601 nest IBOX(k) p = mkNest k (reduceDoc p) -- Externally callable version
603 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
604 mkNest k (Nest k1 p) = mkNest (k PLUS k1) p
605 mkNest k NoDoc = NoDoc
606 mkNest k Empty = Empty
607 mkNest ILIT(0) p = p -- Worth a try!
608 mkNest k p = nest_ k p
610 -- mkUnion checks for an empty document
611 mkUnion Empty q = Empty
612 mkUnion p q = p `union_` q
615 *********************************************************
617 \subsection{Vertical composition @$$@}
619 *********************************************************
623 p $$ q = Above p False q
624 p $+$ q = Above p True q
626 above :: Doc -> Bool -> RDoc -> RDoc
627 above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
628 above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g ILIT(0) (reduceDoc q)
629 above p g q = aboveNest p g ILIT(0) (reduceDoc q)
631 aboveNest :: RDoc -> Bool -> INT -> RDoc -> RDoc
632 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
634 aboveNest NoDoc g k q = NoDoc
635 aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
638 aboveNest Empty g k q = mkNest k q
639 aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k MINUS k1) q)
640 -- p can't be Empty, so no need for mkNest
642 aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
643 aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
647 Empty -> nilAboveNest g k1 q
648 other -> aboveNest p g k1 q
652 nilAboveNest :: Bool -> INT -> RDoc -> RDoc
653 -- Specification: text s <> nilaboveNest g k q
654 -- = text s <> (text "" $g$ nest k q)
656 nilAboveNest g k Empty = Empty -- Here's why the "text s <>" is in the spec!
657 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k PLUS k1) q
659 nilAboveNest g k q | (not g) && (k GR ILIT(0)) -- No newline if no overlap
660 = textBeside_ (Str (spaces k)) k q
661 | otherwise -- Put them really above
662 = nilAbove_ (mkNest k q)
666 *********************************************************
668 \subsection{Horizontal composition @<>@}
670 *********************************************************
673 p <> q = Beside p False q
674 p <+> q = Beside p True q
676 beside :: Doc -> Bool -> RDoc -> RDoc
677 -- Specification: beside g p q = p <g> q
679 beside NoDoc g q = NoDoc
680 beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q)
682 beside (Nest k p) g q = nest_ k $! beside p g q -- p non-empty
683 beside p@(Beside p1 g1 q1) g2 q2
684 {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2
685 [ && (op1 == <> || op1 == <+>) ] -}
686 | g1 == g2 = beside p1 g1 $! beside q1 g2 q2
687 | otherwise = beside (reduceDoc p) g2 q2
688 beside p@(Above _ _ _) g q = let d = reduceDoc p in d `seq` beside d g q
689 beside (NilAbove p) g q = nilAbove_ $! beside p g q
690 beside (TextBeside s sl p) g q = textBeside_ s sl $! rest
693 Empty -> nilBeside g q
694 other -> beside p g q
698 nilBeside :: Bool -> RDoc -> RDoc
699 -- Specification: text "" <> nilBeside g p
702 nilBeside g Empty = Empty -- Hence the text "" in the spec
703 nilBeside g (Nest _ p) = nilBeside g p
704 nilBeside g p | g = textBeside_ space_text ILIT(1) p
708 *********************************************************
710 \subsection{Separate, @sep@, Hughes version}
712 *********************************************************
715 -- Specification: sep ps = oneLiner (hsep ps)
719 sep = sepX True -- Separate with spaces
720 cat = sepX False -- Don't
723 sepX x (p:ps) = sep1 x (reduceDoc p) ILIT(0) ps
726 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
727 -- = oneLiner (x <g> nest k (hsep ys))
728 -- `union` x $$ nest k (vcat ys)
730 sep1 :: Bool -> RDoc -> INT -> [Doc] -> RDoc
731 sep1 g NoDoc k ys = NoDoc
732 sep1 g (p `Union` q) k ys = sep1 g p k ys
734 (aboveNest q False k (reduceDoc (vcat ys)))
736 sep1 g Empty k ys = mkNest k (sepX g ys)
737 sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k MINUS n) ys)
739 sep1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
740 sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k MINUS sl) ys)
742 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
743 -- Called when we have already found some text in the first item
744 -- We have to eat up nests
746 sepNB g (Nest _ p) k ys = sepNB g p k ys
748 sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))
750 nilAboveNest False k (reduceDoc (vcat ys))
753 | otherwise = hcat ys
755 sepNB g p k ys = sep1 g p k ys
758 *********************************************************
762 *********************************************************
771 -- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
772 -- (fill (oneLiner p2 : ps))
777 fill g (p:ps) = fill1 g (reduceDoc p) ILIT(0) ps
780 fill1 :: Bool -> RDoc -> INT -> [Doc] -> Doc
781 fill1 g NoDoc k ys = NoDoc
782 fill1 g (p `Union` q) k ys = fill1 g p k ys
784 (aboveNest q False k (fill g ys))
786 fill1 g Empty k ys = mkNest k (fill g ys)
787 fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k MINUS n) ys)
789 fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
790 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k MINUS sl) ys)
792 fillNB g (Nest _ p) k ys = fillNB g p k ys
793 fillNB g Empty k [] = Empty
794 fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
796 nilAboveNest False k (fill g (y:ys))
798 k1 | g = k MINUS ILIT(1)
801 fillNB g p k ys = fill1 g p k ys
805 *********************************************************
807 \subsection{Selecting the best layout}
809 *********************************************************
812 best :: Int -- Line length
813 -> Int -- Ribbon length
815 -> RDoc -- No unions in here!
817 best IBOX(w) IBOX(r) p
820 get :: INT -- (Remaining) width of line
824 get w (NilAbove p) = nilAbove_ (get w p)
825 get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
826 get w (Nest k p) = nest_ k (get (w MINUS k) p)
827 get w (p `Union` q) = nicest w r (get w p) (get w q)
829 get1 :: INT -- (Remaining) width of line
830 -> INT -- Amount of first line already eaten up
831 -> Doc -- This is an argument to TextBeside => eat Nests
832 -> Doc -- No unions in here!
834 get1 w sl Empty = Empty
835 get1 w sl NoDoc = NoDoc
836 get1 w sl (NilAbove p) = nilAbove_ (get (w MINUS sl) p)
837 get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl PLUS tl) p)
838 get1 w sl (Nest k p) = get1 w sl p
839 get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
842 nicest w r p q = nicest1 w r ILIT(0) p q
843 nicest1 w r sl p q | fits ((w `minn` r) MINUS sl) p = p
846 fits :: INT -- Space available
848 -> Bool -- True if *first line* of Doc fits in space available
850 fits n p | n LT ILIT(0) = False
853 fits n (NilAbove _) = True
854 fits n (TextBeside _ sl p) = fits (n MINUS sl) p
856 minn x y | x LT y = x
860 @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
861 @first@ returns its first argument if it is non-empty, otherwise its second.
864 first p q | nonEmptySet p = p
867 nonEmptySet NoDoc = False
868 nonEmptySet (p `Union` q) = True
869 nonEmptySet Empty = True
870 nonEmptySet (NilAbove p) = True -- NoDoc always in first line
871 nonEmptySet (TextBeside _ _ p) = nonEmptySet p
872 nonEmptySet (Nest _ p) = nonEmptySet p
875 @oneLiner@ returns the one-line members of the given set of @Doc@s.
878 oneLiner :: Doc -> Doc
879 oneLiner NoDoc = NoDoc
880 oneLiner Empty = Empty
881 oneLiner (NilAbove p) = NoDoc
882 oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
883 oneLiner (Nest k p) = nest_ k (oneLiner p)
884 oneLiner (p `Union` q) = oneLiner p
889 *********************************************************
891 \subsection{Displaying the best layout}
893 *********************************************************
898 renderStyle Style{mode, lineLength, ribbonsPerLine} doc
899 = fullRender mode lineLength ribbonsPerLine doc ""
902 render doc = showDocWith PageMode doc
903 showDoc doc rest = showDocWithAppend PageMode doc rest
905 showDocWithAppend :: Mode -> Doc -> String -> String
906 showDocWithAppend mode doc rest = fullRender mode 100 1.5 string_txt rest doc
908 showDocWith :: Mode -> Doc -> String
909 showDocWith mode doc = showDocWithAppend mode doc ""
911 string_txt (Chr c) s = c:s
912 string_txt (Str s1) s2 = s1 ++ s2
913 string_txt (PStr s1) s2 = unpackFS s1 ++ s2
914 string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
916 unpackLitString addr =
920 | ch `eqChar#` '\0'# = []
921 | otherwise = C# ch : unpack (nh +# 1#)
923 ch = indexCharOffAddr# addr nh
928 fullRender OneLineMode _ _ txt end doc
929 = lay (reduceDoc doc)
931 lay NoDoc = cant_fail
932 lay (Union p q) = (lay q) -- Second arg can't be NoDoc
933 lay (Nest k p) = lay p
935 lay (NilAbove p) = space_text `txt` lay p -- NoDoc always on first line
936 lay (TextBeside s sl p) = s `txt` lay p
938 fullRender LeftMode _ _ txt end doc
939 = lay (reduceDoc doc)
941 lay NoDoc = cant_fail
942 lay (Union p q) = lay (first p q)
943 lay (Nest k p) = lay p
945 lay (NilAbove p) = nl_text `txt` lay p -- NoDoc always on first line
946 lay (TextBeside s sl p) = s `txt` lay p
948 fullRender mode line_length ribbons_per_line txt end doc
949 = display mode line_length ribbon_length txt end best_doc
951 best_doc = best hacked_line_length ribbon_length (reduceDoc doc)
953 hacked_line_length, ribbon_length :: Int
954 ribbon_length = round (fromIntegral line_length / ribbons_per_line)
955 hacked_line_length = case mode of { ZigZagMode -> MAXINT; other -> line_length }
957 display mode IBOX(page_width) IBOX(ribbon_width) txt end doc
958 = case page_width MINUS ribbon_width of { gap_width ->
959 case gap_width DIV ILIT(2) of { shift ->
961 lay k (Nest k1 p) = lay (k PLUS k1) p
964 lay k (NilAbove p) = nl_text `txt` lay k p
966 lay k (TextBeside s sl p)
968 ZigZagMode | k GREQ gap_width
970 Str (multi_ch shift '/') `txt` (
972 lay1 (k MINUS shift) s sl p)))
976 Str (multi_ch shift '\\') `txt` (
978 lay1 (k PLUS shift) s sl p )))
980 other -> lay1 k s sl p
982 lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k PLUS sl) p)
984 lay2 k (NilAbove p) = nl_text `txt` lay k p
985 lay2 k (TextBeside s sl p) = s `txt` (lay2 (k PLUS sl) p)
986 lay2 k (Nest _ p) = lay2 k p
992 cant_fail = error "easy_display: NoDoc"
994 indent n | n GREQ ILIT(8) = '\t' : indent (n MINUS ILIT(8))
995 | otherwise = spaces n
997 multi_ch ILIT(0) ch = ""
998 multi_ch n ch = ch : multi_ch (n MINUS ILIT(1)) ch
1001 spaces n = ' ' : spaces (n MINUS ILIT(1))
1005 pprCols = (120 :: Int) -- could make configurable
1007 printDoc :: Mode -> Handle -> Doc -> IO ()
1008 printDoc LeftMode hdl doc
1009 = do { printLeftRender hdl doc; hFlush hdl }
1010 printDoc mode hdl doc
1011 = do { fullRender mode pprCols 1.5 put done doc ;
1014 put (Chr c) next = hPutChar hdl c >> next
1015 put (Str s) next = hPutStr hdl s >> next
1016 put (PStr s) next = hPutFS hdl s >> next
1017 put (LStr s l) next = hPutLitString hdl s l >> next
1019 done = hPutChar hdl '\n'
1021 -- some versions of hPutBuf will barf if the length is zero
1022 hPutLitString handle a# 0# = return ()
1023 hPutLitString handle a# l#
1024 #if __GLASGOW_HASKELL__ < 411
1025 = hPutBuf handle (A# a#) (I# l#)
1027 = hPutBuf handle (Ptr a#) (I# l#)
1030 -- Printing output in LeftMode is performance critical: it's used when
1031 -- dumping C and assembly output, so we allow ourselves a few dirty
1034 -- (1) we specialise fullRender for LeftMode with IO output.
1036 -- (2) we add a layer of buffering on top of Handles. Handles
1037 -- don't perform well with lots of hPutChars, which is mostly
1038 -- what we're doing here, because Handles have to be thread-safe
1039 -- and async exception-safe. We only have a single thread and don't
1040 -- care about exceptions, so we add a layer of fast buffering
1041 -- over the Handle interface.
1043 -- (3) a few hacks in layLeft below to convince GHC to generate the right
1046 printLeftRender :: Handle -> Doc -> IO ()
1047 printLeftRender hdl doc = do
1048 b <- newBufHandle hdl
1049 layLeft b (reduceDoc doc)
1052 -- HACK ALERT! the "return () >>" below convinces GHC to eta-expand
1053 -- this function with the IO state lambda. Otherwise we end up with
1054 -- closures in all the case branches.
1055 layLeft b _ | b `seq` False = undefined -- make it strict in b
1056 layLeft b NoDoc = cant_fail
1057 layLeft b (Union p q) = return () >> layLeft b (first p q)
1058 layLeft b (Nest k p) = return () >> layLeft b p
1059 layLeft b Empty = bPutChar b '\n'
1060 layLeft b (NilAbove p) = bPutChar b '\n' >> layLeft b p
1061 layLeft b (TextBeside s sl p) = put b s >> layLeft b p
1063 put b _ | b `seq` False = undefined
1064 put b (Chr c) = bPutChar b c
1065 put b (Str s) = bPutStr b s
1066 put b (PStr s) = bPutFS b s
1067 put b (LStr s l) = bPutLitString b s l
1069 #if __GLASGOW_HASKELL__ < 503
1070 hPutBuf = hPutBufFull