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 import PrimPacked ( strLength )
200 #if __GLASGOW_HASKELL__ < 411
201 import PrelAddr ( Addr(..) )
203 import Addr ( Addr(..) )
204 import Ptr ( Ptr(..) )
207 -- Don't import Util( assertPanic ) because it makes a loop in the module structure
216 *********************************************************
218 \subsection{CPP magic so that we can compile with both GHC and Hugs}
220 *********************************************************
222 The library uses unboxed types to get a bit more speed, but these CPP macros
223 allow you to use either GHC or Hugs. To get GHC, just set the CPP variable
228 #if defined(__GLASGOW_HASKELL__)
232 -- Disable ASSERT checks; they are expensive!
233 #define LOCAL_ASSERT(x)
236 #define IBOX(x) (I# (x))
239 #define NEGATE negateInt#
244 #define DIV `quotInt#`
248 #define MAXINT maxBound
254 #define LOCAL_ASSERT(x)
259 #define NEGATE negate
268 #define MAXINT maxBound
275 *********************************************************
277 \subsection{The interface}
279 *********************************************************
281 The primitive @Doc@ values
285 isEmpty :: Doc -> Bool
286 text :: String -> Doc
289 semi, comma, colon, space, equals :: Doc
290 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
292 parens, brackets, braces :: Doc -> Doc
293 quotes, doubleQuotes :: Doc -> Doc
296 integer :: Integer -> Doc
297 float :: Float -> Doc
298 double :: Double -> Doc
299 rational :: Rational -> Doc
302 Combining @Doc@ values
305 (<>) :: Doc -> Doc -> Doc -- Beside
306 hcat :: [Doc] -> Doc -- List version of <>
307 (<+>) :: Doc -> Doc -> Doc -- Beside, separated by space
308 hsep :: [Doc] -> Doc -- List version of <+>
310 ($$) :: Doc -> Doc -> Doc -- Above; if there is no
311 -- overlap it "dovetails" the two
312 vcat :: [Doc] -> Doc -- List version of $$
314 cat :: [Doc] -> Doc -- Either hcat or vcat
315 sep :: [Doc] -> Doc -- Either hsep or vcat
316 fcat :: [Doc] -> Doc -- ``Paragraph fill'' version of cat
317 fsep :: [Doc] -> Doc -- ``Paragraph fill'' version of sep
319 nest :: Int -> Doc -> Doc -- Nested
325 hang :: Doc -> Int -> Doc -> Doc
326 punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
329 Displaying @Doc@ values.
332 instance SHOW Doc where
333 showsPrec prec doc cont = showDoc doc cont
335 render :: Doc -> String -- Uses default style
337 -> Int -- Line length
338 -> Float -- Ribbons per line
339 -> (TextDetails -> a -> a) -- What to do with text
340 -> a -- What to do at the end
344 {- When we start using 1.3
345 renderStyle :: Style -> Doc -> String
346 data Style = Style { lineLength :: Int, -- In chars
347 ribbonsPerLine :: Float, -- Ratio of ribbon length to line length
350 style :: Style -- The default style
351 style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
354 data Mode = PageMode -- Normal
355 | ZigZagMode -- With zig-zag cuts
356 | LeftMode -- No indentation, infinitely long lines
357 | OneLineMode -- All on one line
362 *********************************************************
364 \subsection{The @Doc@ calculus}
366 *********************************************************
368 The @Doc@ combinators satisfy the following laws:
372 <a1> (x $$ y) $$ z = x $$ (y $$ z)
380 <b1> (x <> y) <> z = x <> (y <> z)
381 <b2> empty <> x = empty
388 <t1> text s <> text t = text (s++t)
389 <t2> text "" <> x = x, if x non-empty
394 <n2> nest k (nest k' x) = nest (k+k') x
395 <n3> nest k (x <> y) = nest k z <> nest k y
396 <n4> nest k (x $$ y) = nest k x $$ nest k y
397 <n5> nest k empty = empty
398 <n6> x <> nest k y = x <> y, if x non-empty
400 ** Note the side condition on <n6>! It is this that
401 ** makes it OK for empty to be a left unit for <>.
405 <m1> (text s <> x) $$ y = text s <> ((text "" <> x)) $$
408 <m2> (x $$ y) <> z = x $$ (y <> z)
412 Laws for list versions
413 ~~~~~~~~~~~~~~~~~~~~~~
414 <l1> sep (ps++[empty]++qs) = sep (ps ++ qs)
415 ...ditto hsep, hcat, vcat, fill...
417 <l2> nest k (sep ps) = sep (map (nest k) ps)
418 ...ditto hsep, hcat, vcat, fill...
422 <o1> oneLiner (nest k p) = nest k (oneLiner p)
423 <o2> oneLiner (x <> y) = oneLiner x <> oneLiner y
427 You might think that the following verion of <m1> would
430 <3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$
433 But it doesn't work, for if x=empty, we would have
435 text s $$ y = text s <> (empty $$ nest (-length s) y)
436 = text s <> nest (-length s) y
441 *********************************************************
443 \subsection{Simple derived definitions}
445 *********************************************************
460 int n = text (show n)
461 integer n = text (show n)
462 float n = text (show n)
463 double n = text (show n)
464 rational n = text (show (fromRat n))
465 --rational n = text (show (fromRationalX n)) -- _showRational 30 n)
467 quotes p = char '`' <> p <> char '\''
468 doubleQuotes p = char '"' <> p <> char '"'
469 parens p = char '(' <> p <> char ')'
470 brackets p = char '[' <> p <> char ']'
471 braces p = char '{' <> p <> char '}'
474 hcat = foldr (<>) empty
475 hsep = foldr (<+>) empty
476 vcat = foldr ($$) empty
478 hang d1 n d2 = sep [d1, nest n d2]
481 punctuate p (d:ds) = go d ds
484 go d (e:es) = (d <> p) : go e es
488 *********************************************************
490 \subsection{The @Doc@ data type}
492 *********************************************************
494 A @Doc@ represents a {\em set} of layouts. A @Doc@ with
495 no occurrences of @Union@ or @NoDoc@ represents just one layout.
499 | NilAbove Doc -- text "" $$ x
500 | TextBeside TextDetails INT Doc -- text s <> x
501 | Nest INT Doc -- nest k x
502 | Union Doc Doc -- ul `union` ur
503 | NoDoc -- The empty set of documents
504 | Beside Doc Bool Doc -- True <=> space between
505 | Above Doc Bool Doc -- True <=> never overlap
507 type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
510 reduceDoc :: Doc -> RDoc
511 reduceDoc (Beside p g q) = beside p g (reduceDoc q)
512 reduceDoc (Above p g q) = above p g (reduceDoc q)
516 data TextDetails = Chr Char
518 | PStr FastString -- a hashed string
519 | LStr Addr# Int# -- a '\0'-terminated array of bytes
525 Here are the invariants:
528 The argument of @NilAbove@ is never @Empty@. Therefore
529 a @NilAbove@ occupies at least two lines.
532 The arugment of @TextBeside@ is never @Nest@.
535 The layouts of the two arguments of @Union@ both flatten to the same string.
538 The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
541 The right argument of a union cannot be equivalent to the empty set (@NoDoc@).
542 If the left argument of a union is equivalent to the empty set (@NoDoc@),
543 then the @NoDoc@ appears in the first line.
546 An empty document is always represented by @Empty@.
547 It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.
550 The first line of every layout in the left argument of @Union@
551 is longer than the first line of any layout in the right argument.
552 (1) ensures that the left argument has a first line. In view of (3),
553 this invariant means that the right argument must have at least two
558 -- Arg of a NilAbove is always an RDoc
559 nilAbove_ p = LOCAL_ASSERT( ok p ) NilAbove p
564 -- Arg of a TextBeside is always an RDoc
565 textBeside_ s sl p = TextBeside s sl (LOCAL_ASSERT( ok p ) p)
567 ok (Nest _ _) = False
570 -- Arg of Nest is always an RDoc
571 nest_ k p = Nest k (LOCAL_ASSERT( ok p ) p)
576 -- Args of union are always RDocs
577 union_ p q = Union (LOCAL_ASSERT( ok p ) p) (LOCAL_ASSERT( ok q ) q)
579 ok (TextBeside _ _ _) = True
580 ok (NilAbove _) = True
581 ok (Union _ _) = True
586 Notice the difference between
587 * NoDoc (no documents)
588 * Empty (one empty document; no height and no width)
589 * text "" (a document containing the empty string;
590 one line high, but has no width)
594 *********************************************************
596 \subsection{@empty@, @text@, @nest@, @union@}
598 *********************************************************
606 char c = textBeside_ (Chr c) 1# Empty
607 text s = case length s of {IBOX(sl) -> textBeside_ (Str s) sl Empty}
608 ftext s = case lengthFS s of {IBOX(sl) -> textBeside_ (PStr s) sl Empty}
609 ptext (A# s) = case strLength (A# s) of {IBOX(sl) -> textBeside_ (LStr s sl) sl Empty}
611 -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
612 -- intermediate packing/unpacking of the string.
614 "text/str" forall a. text (unpackCString# a) = ptext (A# a)
617 nest IBOX(k) p = mkNest k (reduceDoc p) -- Externally callable version
619 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
620 mkNest k (Nest k1 p) = mkNest (k PLUS k1) p
621 mkNest k NoDoc = NoDoc
622 mkNest k Empty = Empty
623 mkNest ILIT(0) p = p -- Worth a try!
624 mkNest k p = nest_ k p
626 -- mkUnion checks for an empty document
627 mkUnion Empty q = Empty
628 mkUnion p q = p `union_` q
631 *********************************************************
633 \subsection{Vertical composition @$$@}
635 *********************************************************
639 p $$ q = Above p False q
640 p $+$ q = Above p True q
642 above :: Doc -> Bool -> RDoc -> RDoc
643 above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
644 above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g ILIT(0) (reduceDoc q)
645 above p g q = aboveNest p g ILIT(0) (reduceDoc q)
647 aboveNest :: RDoc -> Bool -> INT -> RDoc -> RDoc
648 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
650 aboveNest NoDoc g k q = NoDoc
651 aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
654 aboveNest Empty g k q = mkNest k q
655 aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k MINUS k1) q)
656 -- p can't be Empty, so no need for mkNest
658 aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
659 aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
663 Empty -> nilAboveNest g k1 q
664 other -> aboveNest p g k1 q
668 nilAboveNest :: Bool -> INT -> RDoc -> RDoc
669 -- Specification: text s <> nilaboveNest g k q
670 -- = text s <> (text "" $g$ nest k q)
672 nilAboveNest g k Empty = Empty -- Here's why the "text s <>" is in the spec!
673 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k PLUS k1) q
675 nilAboveNest g k q | (not g) && (k GR ILIT(0)) -- No newline if no overlap
676 = textBeside_ (Str (spaces k)) k q
677 | otherwise -- Put them really above
678 = nilAbove_ (mkNest k q)
682 *********************************************************
684 \subsection{Horizontal composition @<>@}
686 *********************************************************
689 p <> q = Beside p False q
690 p <+> q = Beside p True q
692 beside :: Doc -> Bool -> RDoc -> RDoc
693 -- Specification: beside g p q = p <g> q
695 beside NoDoc g q = NoDoc
696 beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q)
698 beside (Nest k p) g q = nest_ k (beside p g q) -- p non-empty
699 beside p@(Beside p1 g1 q1) g2 q2
700 {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2
701 [ && (op1 == <> || op1 == <+>) ] -}
702 | g1 == g2 = beside p1 g1 (beside q1 g2 q2)
703 | otherwise = beside (reduceDoc p) g2 q2
704 beside p@(Above _ _ _) g q = beside (reduceDoc p) g q
705 beside (NilAbove p) g q = nilAbove_ (beside p g q)
706 beside (TextBeside s sl p) g q = textBeside_ s sl rest
709 Empty -> nilBeside g q
710 other -> beside p g q
714 nilBeside :: Bool -> RDoc -> RDoc
715 -- Specification: text "" <> nilBeside g p
718 nilBeside g Empty = Empty -- Hence the text "" in the spec
719 nilBeside g (Nest _ p) = nilBeside g p
720 nilBeside g p | g = textBeside_ space_text ILIT(1) p
724 *********************************************************
726 \subsection{Separate, @sep@, Hughes version}
728 *********************************************************
731 -- Specification: sep ps = oneLiner (hsep ps)
735 sep = sepX True -- Separate with spaces
736 cat = sepX False -- Don't
739 sepX x (p:ps) = sep1 x (reduceDoc p) ILIT(0) ps
742 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
743 -- = oneLiner (x <g> nest k (hsep ys))
744 -- `union` x $$ nest k (vcat ys)
746 sep1 :: Bool -> RDoc -> INT -> [Doc] -> RDoc
747 sep1 g NoDoc k ys = NoDoc
748 sep1 g (p `Union` q) k ys = sep1 g p k ys
750 (aboveNest q False k (reduceDoc (vcat ys)))
752 sep1 g Empty k ys = mkNest k (sepX g ys)
753 sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k MINUS n) ys)
755 sep1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
756 sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k MINUS sl) ys)
758 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
759 -- Called when we have already found some text in the first item
760 -- We have to eat up nests
762 sepNB g (Nest _ p) k ys = sepNB g p k ys
764 sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))
766 nilAboveNest False k (reduceDoc (vcat ys))
769 | otherwise = hcat ys
771 sepNB g p k ys = sep1 g p k ys
774 *********************************************************
778 *********************************************************
787 -- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
788 -- (fill (oneLiner p2 : ps))
793 fill g (p:ps) = fill1 g (reduceDoc p) ILIT(0) ps
796 fill1 :: Bool -> RDoc -> INT -> [Doc] -> Doc
797 fill1 g NoDoc k ys = NoDoc
798 fill1 g (p `Union` q) k ys = fill1 g p k ys
800 (aboveNest q False k (fill g ys))
802 fill1 g Empty k ys = mkNest k (fill g ys)
803 fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k MINUS n) ys)
805 fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
806 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k MINUS sl) ys)
808 fillNB g (Nest _ p) k ys = fillNB g p k ys
809 fillNB g Empty k [] = Empty
810 fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
812 nilAboveNest False k (fill g (y:ys))
814 k1 | g = k MINUS ILIT(1)
817 fillNB g p k ys = fill1 g p k ys
821 *********************************************************
823 \subsection{Selecting the best layout}
825 *********************************************************
828 best :: Int -- Line length
829 -> Int -- Ribbon length
831 -> RDoc -- No unions in here!
833 best IBOX(w) IBOX(r) p
836 get :: INT -- (Remaining) width of line
840 get w (NilAbove p) = nilAbove_ (get w p)
841 get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
842 get w (Nest k p) = nest_ k (get (w MINUS k) p)
843 get w (p `Union` q) = nicest w r (get w p) (get w q)
845 get1 :: INT -- (Remaining) width of line
846 -> INT -- Amount of first line already eaten up
847 -> Doc -- This is an argument to TextBeside => eat Nests
848 -> Doc -- No unions in here!
850 get1 w sl Empty = Empty
851 get1 w sl NoDoc = NoDoc
852 get1 w sl (NilAbove p) = nilAbove_ (get (w MINUS sl) p)
853 get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl PLUS tl) p)
854 get1 w sl (Nest k p) = get1 w sl p
855 get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
858 nicest w r p q = nicest1 w r ILIT(0) p q
859 nicest1 w r sl p q | fits ((w `minn` r) MINUS sl) p = p
862 fits :: INT -- Space available
864 -> Bool -- True if *first line* of Doc fits in space available
866 fits n p | n LT ILIT(0) = False
869 fits n (NilAbove _) = True
870 fits n (TextBeside _ sl p) = fits (n MINUS sl) p
872 minn x y | x LT y = x
876 @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
877 @first@ returns its first argument if it is non-empty, otherwise its second.
880 first p q | nonEmptySet p = p
883 nonEmptySet NoDoc = False
884 nonEmptySet (p `Union` q) = True
885 nonEmptySet Empty = True
886 nonEmptySet (NilAbove p) = True -- NoDoc always in first line
887 nonEmptySet (TextBeside _ _ p) = nonEmptySet p
888 nonEmptySet (Nest _ p) = nonEmptySet p
891 @oneLiner@ returns the one-line members of the given set of @Doc@s.
894 oneLiner :: Doc -> Doc
895 oneLiner NoDoc = NoDoc
896 oneLiner Empty = Empty
897 oneLiner (NilAbove p) = NoDoc
898 oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
899 oneLiner (Nest k p) = nest_ k (oneLiner p)
900 oneLiner (p `Union` q) = oneLiner p
905 *********************************************************
907 \subsection{Displaying the best layout}
909 *********************************************************
914 renderStyle Style{mode, lineLength, ribbonsPerLine} doc
915 = fullRender mode lineLength ribbonsPerLine doc ""
918 render doc = showDocWith PageMode doc
919 showDoc doc rest = showDocWithAppend PageMode doc rest
921 showDocWithAppend :: Mode -> Doc -> String -> String
922 showDocWithAppend mode doc rest = fullRender mode 100 1.5 string_txt rest doc
924 showDocWith :: Mode -> Doc -> String
925 showDocWith mode doc = showDocWithAppend mode doc ""
927 string_txt (Chr c) s = c:s
928 string_txt (Str s1) s2 = s1 ++ s2
929 string_txt (PStr s1) s2 = unpackFS s1 ++ s2
930 string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
932 unpackLitString addr =
936 | ch `eqChar#` '\0'# = []
937 | otherwise = C# ch : unpack (nh +# 1#)
939 ch = indexCharOffAddr# addr nh
944 fullRender OneLineMode _ _ txt end doc
945 = lay (reduceDoc doc)
947 lay NoDoc = cant_fail
948 lay (Union p q) = (lay q) -- Second arg can't be NoDoc
949 lay (Nest k p) = lay p
951 lay (NilAbove p) = space_text `txt` lay p -- NoDoc always on first line
952 lay (TextBeside s sl p) = s `txt` lay p
954 fullRender LeftMode _ _ txt end doc
955 = lay (reduceDoc doc)
957 lay NoDoc = cant_fail
958 lay (Union p q) = lay (first p q)
959 lay (Nest k p) = lay p
961 lay (NilAbove p) = nl_text `txt` lay p -- NoDoc always on first line
962 lay (TextBeside s sl p) = s `txt` lay p
964 fullRender mode line_length ribbons_per_line txt end doc
965 = display mode line_length ribbon_length txt end best_doc
967 best_doc = best hacked_line_length ribbon_length (reduceDoc doc)
969 hacked_line_length, ribbon_length :: Int
970 ribbon_length = round (fromIntegral line_length / ribbons_per_line)
971 hacked_line_length = case mode of { ZigZagMode -> MAXINT; other -> line_length }
973 display mode IBOX(page_width) IBOX(ribbon_width) txt end doc
974 = case page_width MINUS ribbon_width of { gap_width ->
975 case gap_width DIV ILIT(2) of { shift ->
977 lay k (Nest k1 p) = lay (k PLUS k1) p
980 lay k (NilAbove p) = nl_text `txt` lay k p
982 lay k (TextBeside s sl p)
984 ZigZagMode | k GREQ gap_width
986 Str (multi_ch shift '/') `txt` (
988 lay1 (k MINUS shift) s sl p)))
992 Str (multi_ch shift '\\') `txt` (
994 lay1 (k PLUS shift) s sl p )))
996 other -> lay1 k s sl p
998 lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k PLUS sl) p)
1000 lay2 k (NilAbove p) = nl_text `txt` lay k p
1001 lay2 k (TextBeside s sl p) = s `txt` (lay2 (k PLUS sl) p)
1002 lay2 k (Nest _ p) = lay2 k p
1008 cant_fail = error "easy_display: NoDoc"
1010 indent n | n GREQ ILIT(8) = '\t' : indent (n MINUS ILIT(8))
1011 | otherwise = spaces n
1013 multi_ch ILIT(0) ch = ""
1014 multi_ch n ch = ch : multi_ch (n MINUS ILIT(1)) ch
1017 spaces n = ' ' : spaces (n MINUS ILIT(1))
1021 pprCols = (100 :: Int) -- could make configurable
1023 printDoc :: Mode -> Handle -> Doc -> IO ()
1024 printDoc mode hdl doc
1025 = fullRender mode pprCols 1.5 put done doc
1027 put (Chr c) next = hPutChar hdl c >> next
1028 put (Str s) next = hPutStr hdl s >> next
1029 put (PStr s) next = hPutFS hdl s >> next
1030 put (LStr s l) next = hPutLitString hdl s l >> next
1032 done = hPutChar hdl '\n'
1034 #if __GLASGOW_HASKELL__ < 503
1035 hPutBuf = hPutBufFull
1038 hPutLitString handle a# l#
1039 #if __GLASGOW_HASKELL__ < 411
1040 = hPutBuf handle (A# a#) (I# l#)
1042 = hPutBuf handle (Ptr a#) (I# l#)