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 Numeric (fromRat)
183 import PrimPacked ( strLength )
186 #if __GLASGOW_HASKELL__ < 503
187 import IOExts ( hPutBufFull )
189 import System.IO ( hPutBuf )
192 #if __GLASGOW_HASKELL__ < 503
193 import PrelBase ( unpackCString# )
195 import GHC.Base ( unpackCString# )
198 #if __GLASGOW_HASKELL__ < 411
199 import PrelAddr ( Addr(..) )
201 import Addr ( Addr(..) )
202 #if __GLASGOW_HASKELL__ < 503
203 import Ptr ( Ptr(..) )
205 import GHC.Ptr ( Ptr(..) )
209 -- Don't import Util( assertPanic ) because it makes a loop in the module structure
218 *********************************************************
220 \subsection{CPP magic so that we can compile with both GHC and Hugs}
222 *********************************************************
224 The library uses unboxed types to get a bit more speed, but these CPP macros
225 allow you to use either GHC or Hugs. To get GHC, just set the CPP variable
230 #if defined(__GLASGOW_HASKELL__)
234 -- Disable ASSERT checks; they are expensive!
235 #define LOCAL_ASSERT(x)
238 #define IBOX(x) (I# (x))
241 #define NEGATE negateInt#
246 #define DIV `quotInt#`
250 #define MAXINT maxBound
256 #define LOCAL_ASSERT(x)
261 #define NEGATE negate
270 #define MAXINT maxBound
277 *********************************************************
279 \subsection{The interface}
281 *********************************************************
283 The primitive @Doc@ values
287 isEmpty :: Doc -> Bool
288 text :: String -> Doc
291 semi, comma, colon, space, equals :: Doc
292 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
294 parens, brackets, braces :: Doc -> Doc
295 quotes, doubleQuotes :: Doc -> Doc
298 integer :: Integer -> Doc
299 float :: Float -> Doc
300 double :: Double -> Doc
301 rational :: Rational -> Doc
304 Combining @Doc@ values
307 (<>) :: Doc -> Doc -> Doc -- Beside
308 hcat :: [Doc] -> Doc -- List version of <>
309 (<+>) :: Doc -> Doc -> Doc -- Beside, separated by space
310 hsep :: [Doc] -> Doc -- List version of <+>
312 ($$) :: Doc -> Doc -> Doc -- Above; if there is no
313 -- overlap it "dovetails" the two
314 vcat :: [Doc] -> Doc -- List version of $$
316 cat :: [Doc] -> Doc -- Either hcat or vcat
317 sep :: [Doc] -> Doc -- Either hsep or vcat
318 fcat :: [Doc] -> Doc -- ``Paragraph fill'' version of cat
319 fsep :: [Doc] -> Doc -- ``Paragraph fill'' version of sep
321 nest :: Int -> Doc -> Doc -- Nested
327 hang :: Doc -> Int -> Doc -> Doc
328 punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
331 Displaying @Doc@ values.
334 instance SHOW Doc where
335 showsPrec prec doc cont = showDoc doc cont
337 render :: Doc -> String -- Uses default style
339 -> Int -- Line length
340 -> Float -- Ribbons per line
341 -> (TextDetails -> a -> a) -- What to do with text
342 -> a -- What to do at the end
346 {- When we start using 1.3
347 renderStyle :: Style -> Doc -> String
348 data Style = Style { lineLength :: Int, -- In chars
349 ribbonsPerLine :: Float, -- Ratio of ribbon length to line length
352 style :: Style -- The default style
353 style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
356 data Mode = PageMode -- Normal
357 | ZigZagMode -- With zig-zag cuts
358 | LeftMode -- No indentation, infinitely long lines
359 | OneLineMode -- All on one line
364 *********************************************************
366 \subsection{The @Doc@ calculus}
368 *********************************************************
370 The @Doc@ combinators satisfy the following laws:
374 <a1> (x $$ y) $$ z = x $$ (y $$ z)
382 <b1> (x <> y) <> z = x <> (y <> z)
383 <b2> empty <> x = empty
390 <t1> text s <> text t = text (s++t)
391 <t2> text "" <> x = x, if x non-empty
396 <n2> nest k (nest k' x) = nest (k+k') x
397 <n3> nest k (x <> y) = nest k z <> nest k y
398 <n4> nest k (x $$ y) = nest k x $$ nest k y
399 <n5> nest k empty = empty
400 <n6> x <> nest k y = x <> y, if x non-empty
402 ** Note the side condition on <n6>! It is this that
403 ** makes it OK for empty to be a left unit for <>.
407 <m1> (text s <> x) $$ y = text s <> ((text "" <> x)) $$
410 <m2> (x $$ y) <> z = x $$ (y <> z)
414 Laws for list versions
415 ~~~~~~~~~~~~~~~~~~~~~~
416 <l1> sep (ps++[empty]++qs) = sep (ps ++ qs)
417 ...ditto hsep, hcat, vcat, fill...
419 <l2> nest k (sep ps) = sep (map (nest k) ps)
420 ...ditto hsep, hcat, vcat, fill...
424 <o1> oneLiner (nest k p) = nest k (oneLiner p)
425 <o2> oneLiner (x <> y) = oneLiner x <> oneLiner y
429 You might think that the following verion of <m1> would
432 <3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$
435 But it doesn't work, for if x=empty, we would have
437 text s $$ y = text s <> (empty $$ nest (-length s) y)
438 = text s <> nest (-length s) y
443 *********************************************************
445 \subsection{Simple derived definitions}
447 *********************************************************
462 int n = text (show n)
463 integer n = text (show n)
464 float n = text (show n)
465 double n = text (show n)
466 rational n = text (show (fromRat n))
467 --rational n = text (show (fromRationalX n)) -- _showRational 30 n)
469 quotes p = char '`' <> p <> char '\''
470 doubleQuotes p = char '"' <> p <> char '"'
471 parens p = char '(' <> p <> char ')'
472 brackets p = char '[' <> p <> char ']'
473 braces p = char '{' <> p <> char '}'
476 hcat = foldr (<>) empty
477 hsep = foldr (<+>) empty
478 vcat = foldr ($$) empty
480 hang d1 n d2 = sep [d1, nest n d2]
483 punctuate p (d:ds) = go d ds
486 go d (e:es) = (d <> p) : go e es
490 *********************************************************
492 \subsection{The @Doc@ data type}
494 *********************************************************
496 A @Doc@ represents a {\em set} of layouts. A @Doc@ with
497 no occurrences of @Union@ or @NoDoc@ represents just one layout.
501 | NilAbove Doc -- text "" $$ x
502 | TextBeside TextDetails INT Doc -- text s <> x
503 | Nest INT Doc -- nest k x
504 | Union Doc Doc -- ul `union` ur
505 | NoDoc -- The empty set of documents
506 | Beside Doc Bool Doc -- True <=> space between
507 | Above Doc Bool Doc -- True <=> never overlap
509 type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
512 reduceDoc :: Doc -> RDoc
513 reduceDoc (Beside p g q) = beside p g (reduceDoc q)
514 reduceDoc (Above p g q) = above p g (reduceDoc q)
518 data TextDetails = Chr Char
520 | PStr FastString -- a hashed string
521 | LStr Addr# Int# -- a '\0'-terminated array of bytes
527 Here are the invariants:
530 The argument of @NilAbove@ is never @Empty@. Therefore
531 a @NilAbove@ occupies at least two lines.
534 The arugment of @TextBeside@ is never @Nest@.
537 The layouts of the two arguments of @Union@ both flatten to the same string.
540 The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
543 The right argument of a union cannot be equivalent to the empty set (@NoDoc@).
544 If the left argument of a union is equivalent to the empty set (@NoDoc@),
545 then the @NoDoc@ appears in the first line.
548 An empty document is always represented by @Empty@.
549 It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.
552 The first line of every layout in the left argument of @Union@
553 is longer than the first line of any layout in the right argument.
554 (1) ensures that the left argument has a first line. In view of (3),
555 this invariant means that the right argument must have at least two
560 -- Arg of a NilAbove is always an RDoc
561 nilAbove_ p = LOCAL_ASSERT( ok p ) NilAbove p
566 -- Arg of a TextBeside is always an RDoc
567 textBeside_ s sl p = TextBeside s sl (LOCAL_ASSERT( ok p ) p)
569 ok (Nest _ _) = False
572 -- Arg of Nest is always an RDoc
573 nest_ k p = Nest k (LOCAL_ASSERT( ok p ) p)
578 -- Args of union are always RDocs
579 union_ p q = Union (LOCAL_ASSERT( ok p ) p) (LOCAL_ASSERT( ok q ) q)
581 ok (TextBeside _ _ _) = True
582 ok (NilAbove _) = True
583 ok (Union _ _) = True
588 Notice the difference between
589 * NoDoc (no documents)
590 * Empty (one empty document; no height and no width)
591 * text "" (a document containing the empty string;
592 one line high, but has no width)
596 *********************************************************
598 \subsection{@empty@, @text@, @nest@, @union@}
600 *********************************************************
608 char c = textBeside_ (Chr c) 1# Empty
609 text s = case length s of {IBOX(sl) -> textBeside_ (Str s) sl Empty}
610 ftext s = case lengthFS s of {IBOX(sl) -> textBeside_ (PStr s) sl Empty}
611 ptext (A# s) = case strLength (A# s) of {IBOX(sl) -> textBeside_ (LStr s sl) sl Empty}
613 -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
614 -- intermediate packing/unpacking of the string.
616 "text/str" forall a. text (unpackCString# a) = ptext (A# a)
619 nest IBOX(k) p = mkNest k (reduceDoc p) -- Externally callable version
621 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
622 mkNest k (Nest k1 p) = mkNest (k PLUS k1) p
623 mkNest k NoDoc = NoDoc
624 mkNest k Empty = Empty
625 mkNest ILIT(0) p = p -- Worth a try!
626 mkNest k p = nest_ k p
628 -- mkUnion checks for an empty document
629 mkUnion Empty q = Empty
630 mkUnion p q = p `union_` q
633 *********************************************************
635 \subsection{Vertical composition @$$@}
637 *********************************************************
641 p $$ q = Above p False q
642 p $+$ q = Above p True q
644 above :: Doc -> Bool -> RDoc -> RDoc
645 above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
646 above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g ILIT(0) (reduceDoc q)
647 above p g q = aboveNest p g ILIT(0) (reduceDoc q)
649 aboveNest :: RDoc -> Bool -> INT -> RDoc -> RDoc
650 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
652 aboveNest NoDoc g k q = NoDoc
653 aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
656 aboveNest Empty g k q = mkNest k q
657 aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k MINUS k1) q)
658 -- p can't be Empty, so no need for mkNest
660 aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
661 aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
665 Empty -> nilAboveNest g k1 q
666 other -> aboveNest p g k1 q
670 nilAboveNest :: Bool -> INT -> RDoc -> RDoc
671 -- Specification: text s <> nilaboveNest g k q
672 -- = text s <> (text "" $g$ nest k q)
674 nilAboveNest g k Empty = Empty -- Here's why the "text s <>" is in the spec!
675 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k PLUS k1) q
677 nilAboveNest g k q | (not g) && (k GR ILIT(0)) -- No newline if no overlap
678 = textBeside_ (Str (spaces k)) k q
679 | otherwise -- Put them really above
680 = nilAbove_ (mkNest k q)
684 *********************************************************
686 \subsection{Horizontal composition @<>@}
688 *********************************************************
691 p <> q = Beside p False q
692 p <+> q = Beside p True q
694 beside :: Doc -> Bool -> RDoc -> RDoc
695 -- Specification: beside g p q = p <g> q
697 beside NoDoc g q = NoDoc
698 beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q)
700 beside (Nest k p) g q = nest_ k (beside p g q) -- p non-empty
701 beside p@(Beside p1 g1 q1) g2 q2
702 {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2
703 [ && (op1 == <> || op1 == <+>) ] -}
704 | g1 == g2 = beside p1 g1 (beside q1 g2 q2)
705 | otherwise = beside (reduceDoc p) g2 q2
706 beside p@(Above _ _ _) g q = beside (reduceDoc p) g q
707 beside (NilAbove p) g q = nilAbove_ (beside p g q)
708 beside (TextBeside s sl p) g q = textBeside_ s sl rest
711 Empty -> nilBeside g q
712 other -> beside p g q
716 nilBeside :: Bool -> RDoc -> RDoc
717 -- Specification: text "" <> nilBeside g p
720 nilBeside g Empty = Empty -- Hence the text "" in the spec
721 nilBeside g (Nest _ p) = nilBeside g p
722 nilBeside g p | g = textBeside_ space_text ILIT(1) p
726 *********************************************************
728 \subsection{Separate, @sep@, Hughes version}
730 *********************************************************
733 -- Specification: sep ps = oneLiner (hsep ps)
737 sep = sepX True -- Separate with spaces
738 cat = sepX False -- Don't
741 sepX x (p:ps) = sep1 x (reduceDoc p) ILIT(0) ps
744 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
745 -- = oneLiner (x <g> nest k (hsep ys))
746 -- `union` x $$ nest k (vcat ys)
748 sep1 :: Bool -> RDoc -> INT -> [Doc] -> RDoc
749 sep1 g NoDoc k ys = NoDoc
750 sep1 g (p `Union` q) k ys = sep1 g p k ys
752 (aboveNest q False k (reduceDoc (vcat ys)))
754 sep1 g Empty k ys = mkNest k (sepX g ys)
755 sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k MINUS n) ys)
757 sep1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
758 sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k MINUS sl) ys)
760 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
761 -- Called when we have already found some text in the first item
762 -- We have to eat up nests
764 sepNB g (Nest _ p) k ys = sepNB g p k ys
766 sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))
768 nilAboveNest False k (reduceDoc (vcat ys))
771 | otherwise = hcat ys
773 sepNB g p k ys = sep1 g p k ys
776 *********************************************************
780 *********************************************************
789 -- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
790 -- (fill (oneLiner p2 : ps))
795 fill g (p:ps) = fill1 g (reduceDoc p) ILIT(0) ps
798 fill1 :: Bool -> RDoc -> INT -> [Doc] -> Doc
799 fill1 g NoDoc k ys = NoDoc
800 fill1 g (p `Union` q) k ys = fill1 g p k ys
802 (aboveNest q False k (fill g ys))
804 fill1 g Empty k ys = mkNest k (fill g ys)
805 fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k MINUS n) ys)
807 fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
808 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k MINUS sl) ys)
810 fillNB g (Nest _ p) k ys = fillNB g p k ys
811 fillNB g Empty k [] = Empty
812 fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
814 nilAboveNest False k (fill g (y:ys))
816 k1 | g = k MINUS ILIT(1)
819 fillNB g p k ys = fill1 g p k ys
823 *********************************************************
825 \subsection{Selecting the best layout}
827 *********************************************************
830 best :: Int -- Line length
831 -> Int -- Ribbon length
833 -> RDoc -- No unions in here!
835 best IBOX(w) IBOX(r) p
838 get :: INT -- (Remaining) width of line
842 get w (NilAbove p) = nilAbove_ (get w p)
843 get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
844 get w (Nest k p) = nest_ k (get (w MINUS k) p)
845 get w (p `Union` q) = nicest w r (get w p) (get w q)
847 get1 :: INT -- (Remaining) width of line
848 -> INT -- Amount of first line already eaten up
849 -> Doc -- This is an argument to TextBeside => eat Nests
850 -> Doc -- No unions in here!
852 get1 w sl Empty = Empty
853 get1 w sl NoDoc = NoDoc
854 get1 w sl (NilAbove p) = nilAbove_ (get (w MINUS sl) p)
855 get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl PLUS tl) p)
856 get1 w sl (Nest k p) = get1 w sl p
857 get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
860 nicest w r p q = nicest1 w r ILIT(0) p q
861 nicest1 w r sl p q | fits ((w `minn` r) MINUS sl) p = p
864 fits :: INT -- Space available
866 -> Bool -- True if *first line* of Doc fits in space available
868 fits n p | n LT ILIT(0) = False
871 fits n (NilAbove _) = True
872 fits n (TextBeside _ sl p) = fits (n MINUS sl) p
874 minn x y | x LT y = x
878 @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
879 @first@ returns its first argument if it is non-empty, otherwise its second.
882 first p q | nonEmptySet p = p
885 nonEmptySet NoDoc = False
886 nonEmptySet (p `Union` q) = True
887 nonEmptySet Empty = True
888 nonEmptySet (NilAbove p) = True -- NoDoc always in first line
889 nonEmptySet (TextBeside _ _ p) = nonEmptySet p
890 nonEmptySet (Nest _ p) = nonEmptySet p
893 @oneLiner@ returns the one-line members of the given set of @Doc@s.
896 oneLiner :: Doc -> Doc
897 oneLiner NoDoc = NoDoc
898 oneLiner Empty = Empty
899 oneLiner (NilAbove p) = NoDoc
900 oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
901 oneLiner (Nest k p) = nest_ k (oneLiner p)
902 oneLiner (p `Union` q) = oneLiner p
907 *********************************************************
909 \subsection{Displaying the best layout}
911 *********************************************************
916 renderStyle Style{mode, lineLength, ribbonsPerLine} doc
917 = fullRender mode lineLength ribbonsPerLine doc ""
920 render doc = showDocWith PageMode doc
921 showDoc doc rest = showDocWithAppend PageMode doc rest
923 showDocWithAppend :: Mode -> Doc -> String -> String
924 showDocWithAppend mode doc rest = fullRender mode 100 1.5 string_txt rest doc
926 showDocWith :: Mode -> Doc -> String
927 showDocWith mode doc = showDocWithAppend mode doc ""
929 string_txt (Chr c) s = c:s
930 string_txt (Str s1) s2 = s1 ++ s2
931 string_txt (PStr s1) s2 = unpackFS s1 ++ s2
932 string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
934 unpackLitString addr =
938 | ch `eqChar#` '\0'# = []
939 | otherwise = C# ch : unpack (nh +# 1#)
941 ch = indexCharOffAddr# addr nh
946 fullRender OneLineMode _ _ txt end doc
947 = lay (reduceDoc doc)
949 lay NoDoc = cant_fail
950 lay (Union p q) = (lay q) -- Second arg can't be NoDoc
951 lay (Nest k p) = lay p
953 lay (NilAbove p) = space_text `txt` lay p -- NoDoc always on first line
954 lay (TextBeside s sl p) = s `txt` lay p
956 fullRender LeftMode _ _ txt end doc
957 = lay (reduceDoc doc)
959 lay NoDoc = cant_fail
960 lay (Union p q) = lay (first p q)
961 lay (Nest k p) = lay p
963 lay (NilAbove p) = nl_text `txt` lay p -- NoDoc always on first line
964 lay (TextBeside s sl p) = s `txt` lay p
966 fullRender mode line_length ribbons_per_line txt end doc
967 = display mode line_length ribbon_length txt end best_doc
969 best_doc = best hacked_line_length ribbon_length (reduceDoc doc)
971 hacked_line_length, ribbon_length :: Int
972 ribbon_length = round (fromIntegral line_length / ribbons_per_line)
973 hacked_line_length = case mode of { ZigZagMode -> MAXINT; other -> line_length }
975 display mode IBOX(page_width) IBOX(ribbon_width) txt end doc
976 = case page_width MINUS ribbon_width of { gap_width ->
977 case gap_width DIV ILIT(2) of { shift ->
979 lay k (Nest k1 p) = lay (k PLUS k1) p
982 lay k (NilAbove p) = nl_text `txt` lay k p
984 lay k (TextBeside s sl p)
986 ZigZagMode | k GREQ gap_width
988 Str (multi_ch shift '/') `txt` (
990 lay1 (k MINUS shift) s sl p)))
994 Str (multi_ch shift '\\') `txt` (
996 lay1 (k PLUS shift) s sl p )))
998 other -> lay1 k s sl p
1000 lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k PLUS sl) p)
1002 lay2 k (NilAbove p) = nl_text `txt` lay k p
1003 lay2 k (TextBeside s sl p) = s `txt` (lay2 (k PLUS sl) p)
1004 lay2 k (Nest _ p) = lay2 k p
1010 cant_fail = error "easy_display: NoDoc"
1012 indent n | n GREQ ILIT(8) = '\t' : indent (n MINUS ILIT(8))
1013 | otherwise = spaces n
1015 multi_ch ILIT(0) ch = ""
1016 multi_ch n ch = ch : multi_ch (n MINUS ILIT(1)) ch
1019 spaces n = ' ' : spaces (n MINUS ILIT(1))
1023 pprCols = (100 :: Int) -- could make configurable
1025 printDoc :: Mode -> Handle -> Doc -> IO ()
1026 printDoc mode hdl doc
1027 = fullRender mode pprCols 1.5 put done doc
1029 put (Chr c) next = hPutChar hdl c >> next
1030 put (Str s) next = hPutStr hdl s >> next
1031 put (PStr s) next = hPutFS hdl s >> next
1032 put (LStr s l) next = hPutLitString hdl s l >> next
1034 done = hPutChar hdl '\n'
1036 #if __GLASGOW_HASKELL__ < 503
1037 hPutBuf = hPutBufFull
1040 -- some versions of hPutBuf will barf if the length is zero
1041 hPutLitString handle a# 0# = return ()
1042 hPutLitString handle a# l#
1043 #if __GLASGOW_HASKELL__ < 411
1044 = hPutBuf handle (A# a#) (I# l#)
1046 = hPutBuf handle (Ptr a#) (I# l#)