X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FPretty.lhs;h=317022d66927e819f57e1fb4df9f514f06d542c5;hp=c4365a38c91aa49c22348961225ca671d77dd582;hb=5289f5d85610f71625a439747a09384876655eb5;hpb=a1706e166ef400bab3b15a8fd80145ede6655c62 diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs index c4365a3..317022d 100644 --- a/compiler/utils/Pretty.lhs +++ b/compiler/utils/Pretty.lhs @@ -1,15 +1,15 @@ -********************************************************************************* -* * -* John Hughes's and Simon Peyton Jones's Pretty Printer Combinators * -* * -* based on "The Design of a Pretty-printing Library" * -* in Advanced Functional Programming, * -* Johan Jeuring and Erik Meijer (eds), LNCS 925 * -* http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps * -* * -* Heavily modified by Simon Peyton Jones, Dec 96 * -* * -********************************************************************************* +%********************************************************************************* +%* * +%* John Hughes's and Simon Peyton Jones's Pretty Printer Combinators * +%* * +%* based on "The Design of a Pretty-printing Library" * +%* in Advanced Functional Programming, * +%* Johan Jeuring and Erik Meijer (eds), LNCS 925 * +%* http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps * +%* * +%* Heavily modified by Simon Peyton Jones, Dec 96 * +%* * +%********************************************************************************* Version 3.0 28 May 1997 * Cured massive performance bug. If you write @@ -152,12 +152,10 @@ Relative to John's original paper, there are the following new features: \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS -fno-warn-unused-imports #-} +-- XXX GHC 6.9 seems to be confused by unpackCString# being used only in +-- a RULE module Pretty ( Doc, -- Abstract @@ -165,7 +163,7 @@ module Pretty ( empty, isEmpty, nest, - text, char, ftext, ptext, + char, text, ftext, ptext, int, integer, float, double, rational, parens, brackets, braces, quotes, doubleQuotes, semi, comma, colon, space, equals, @@ -179,14 +177,14 @@ module Pretty ( hang, punctuate, -- renderStyle, -- Haskell 1.3 only - render, fullRender, printDoc, showDocWith + render, fullRender, printDoc, showDocWith, + bufLeftRender -- performance hack ) where -#include "HsVersions.h" - import BufWrite import FastString import FastTypes +import Panic import Numeric (fromRat) import System.IO @@ -195,6 +193,7 @@ import System.IO #if defined(__GLASGOW_HASKELL__) --for a RULES import GHC.Base ( unpackCString# ) +import GHC.Exts ( Int# ) import GHC.Ptr ( Ptr(..) ) #endif @@ -214,11 +213,11 @@ infixl 5 $$, $+$ \end{code} -********************************************************* -* * +%********************************************************* +%* * \subsection{The interface} -* * -********************************************************* +%* * +%********************************************************* The primitive @Doc@ values @@ -272,7 +271,7 @@ Displaying @Doc@ values. \begin{code} instance Show Doc where - showsPrec prec doc cont = showDoc doc cont + showsPrec _ doc cont = showDoc doc cont render :: Doc -> String -- Uses default style fullRender :: Mode @@ -301,11 +300,11 @@ data Mode = PageMode -- Normal \end{code} -********************************************************* -* * +%********************************************************* +%* * \subsection{The @Doc@ calculus} -* * -********************************************************* +%* * +%********************************************************* The @Doc@ combinators satisfy the following laws: \begin{verbatim} @@ -339,8 +338,8 @@ Laws for nest nest k empty = empty x <> nest k y = x <> y, if x non-empty -** Note the side condition on ! It is this that -** makes it OK for empty to be a left unit for <>. + - Note the side condition on ! It is this that + makes it OK for empty to be a left unit for <>. Miscellaneous ~~~~~~~~~~~~~ @@ -380,11 +379,11 @@ But it doesn't work, for if x=empty, we would have -********************************************************* -* * +%********************************************************* +%* * \subsection{Simple derived definitions} -* * -********************************************************* +%* * +%********************************************************* \begin{code} semi = char ';' @@ -412,6 +411,7 @@ parens p = char '(' <> p <> char ')' brackets p = char '[' <> p <> char ']' braces p = char '{' <> p <> char '}' +cparen :: Bool -> Doc -> Doc cparen True = parens cparen False = id @@ -421,7 +421,7 @@ vcat = foldr ($$) empty hang d1 n d2 = sep [d1, nest n d2] -punctuate p [] = [] +punctuate _ [] = [] punctuate p (d:ds) = go d ds where go d [] = [d] @@ -429,11 +429,11 @@ punctuate p (d:ds) = go d ds \end{code} -********************************************************* -* * +%********************************************************* +%* * \subsection{The @Doc@ data type} -* * -********************************************************* +%* * +%********************************************************* A @Doc@ represents a {\em set} of layouts. A @Doc@ with no occurrences of @Union@ or @NoDoc@ represents just one layout. @@ -463,7 +463,9 @@ data TextDetails = Chr {-#UNPACK#-}!Char | LStr {-#UNPACK#-}!LitString FastInt -- a '\0'-terminated -- array of bytes +space_text :: TextDetails space_text = Chr ' ' +nl_text :: TextDetails nl_text = Chr '\n' \end{code} @@ -500,34 +502,37 @@ lines. \end{itemize} \begin{code} - -- Arg of a NilAbove is always an RDoc -nilAbove_ p = LOCAL_ASSERT( ok p ) NilAbove p +-- Arg of a NilAbove is always an RDoc +nilAbove_ :: Doc -> Doc +nilAbove_ p = LOCAL_ASSERT( _ok p ) NilAbove p where - ok Empty = False - ok other = True + _ok Empty = False + _ok _ = True - -- Arg of a TextBeside is always an RDoc -textBeside_ s sl p = TextBeside s sl (LOCAL_ASSERT( ok p ) p) +-- Arg of a TextBeside is always an RDoc +textBeside_ :: TextDetails -> FastInt -> Doc -> Doc +textBeside_ s sl p = TextBeside s sl (LOCAL_ASSERT( _ok p ) p) where - ok (Nest _ _) = False - ok other = True + _ok (Nest _ _) = False + _ok _ = True - -- Arg of Nest is always an RDoc -nest_ k p = Nest k (LOCAL_ASSERT( ok p ) p) +-- Arg of Nest is always an RDoc +nest_ :: FastInt -> Doc -> Doc +nest_ k p = Nest k (LOCAL_ASSERT( _ok p ) p) where - ok Empty = False - ok other = True + _ok Empty = False + _ok _ = True - -- Args of union are always RDocs -union_ p q = Union (LOCAL_ASSERT( ok p ) p) (LOCAL_ASSERT( ok q ) q) +-- Args of union are always RDocs +union_ :: Doc -> Doc -> Doc +union_ p q = Union (LOCAL_ASSERT( _ok p ) p) (LOCAL_ASSERT( _ok q ) q) where - ok (TextBeside _ _ _) = True - ok (NilAbove _) = True - ok (Union _ _) = True - ok other = False + _ok (TextBeside _ _ _) = True + _ok (NilAbove _) = True + _ok (Union _ _) = True + _ok _ = False \end{code} - Notice the difference between * NoDoc (no documents) * Empty (one empty document; no height and no width) @@ -536,11 +541,11 @@ Notice the difference between -********************************************************* -* * +%********************************************************* +%* * \subsection{@empty@, @text@, @nest@, @union@} -* * -********************************************************* +%* * +%********************************************************* \begin{code} empty = Empty @@ -550,8 +555,10 @@ isEmpty _ = False char c = textBeside_ (Chr c) (_ILIT(1)) Empty text s = case iUnbox (length s) of {sl -> textBeside_ (Str s) sl Empty} +ftext :: FastString -> Doc ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty} -ptext s_= case iUnbox (strLength s) of {sl -> textBeside_ (LStr s sl) sl Empty} +ptext :: LitString -> Doc +ptext s_= case iUnbox (lengthLS s) of {sl -> textBeside_ (LStr s sl) sl Empty} where s = {-castPtr-} s_ #if defined(__GLASGOW_HASKELL__) @@ -565,26 +572,29 @@ ptext s_= case iUnbox (strLength s) of {sl -> textBeside_ (LStr s sl) sl Empty} nest k p = mkNest (iUnbox k) (reduceDoc p) -- Externally callable version -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it +mkNest :: Int# -> Doc -> Doc mkNest k (Nest k1 p) = mkNest (k +# k1) p -mkNest k NoDoc = NoDoc -mkNest k Empty = Empty +mkNest _ NoDoc = NoDoc +mkNest _ Empty = Empty mkNest k p | k ==# _ILIT(0) = p -- Worth a try! mkNest k p = nest_ k p -- mkUnion checks for an empty document -mkUnion Empty q = Empty +mkUnion :: Doc -> Doc -> Doc +mkUnion Empty _ = Empty mkUnion p q = p `union_` q \end{code} -********************************************************* -* * +%********************************************************* +%* * \subsection{Vertical composition @$$@} -* * -********************************************************* +%* * +%********************************************************* \begin{code} p $$ q = Above p False q +($+$) :: Doc -> Doc -> Doc p $+$ q = Above p True q above :: Doc -> Bool -> RDoc -> RDoc @@ -595,21 +605,22 @@ above p g q = aboveNest p g (_ILIT(0)) (reduceDoc q aboveNest :: RDoc -> Bool -> FastInt -> RDoc -> RDoc -- Specfication: aboveNest p g k q = p $g$ (nest k q) -aboveNest NoDoc g k q = NoDoc +aboveNest NoDoc _ _ _ = NoDoc aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` aboveNest p2 g k q -aboveNest Empty g k q = mkNest k q +aboveNest Empty _ k q = mkNest k q aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k -# k1) q) -- p can't be Empty, so no need for mkNest aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q) aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest where - k1 = k -# sl + !k1 = k -# sl rest = case p of Empty -> nilAboveNest g k1 q - other -> aboveNest p g k1 q + _ -> aboveNest p g k1 q +aboveNest _ _ _ _ = panic "aboveNest: Unhandled case" \end{code} \begin{code} @@ -617,7 +628,7 @@ nilAboveNest :: Bool -> FastInt -> RDoc -> RDoc -- Specification: text s <> nilaboveNest g k q -- = text s <> (text "" $g$ nest k q) -nilAboveNest g k Empty = Empty -- Here's why the "text s <>" is in the spec! +nilAboveNest _ _ Empty = Empty -- Here's why the "text s <>" is in the spec! nilAboveNest g k (Nest k1 q) = nilAboveNest g (k +# k1) q nilAboveNest g k q | (not g) && (k ># _ILIT(0)) -- No newline if no overlap @@ -627,11 +638,11 @@ nilAboveNest g k q | (not g) && (k ># _ILIT(0)) -- No newline i \end{code} -********************************************************* -* * +%********************************************************* +%* * \subsection{Horizontal composition @<>@} -* * -********************************************************* +%* * +%********************************************************* \begin{code} p <> q = Beside p False q @@ -640,9 +651,9 @@ p <+> q = Beside p True q beside :: Doc -> Bool -> RDoc -> RDoc -- Specification: beside g p q = p q -beside NoDoc g q = NoDoc +beside NoDoc _ _ = NoDoc beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q) -beside Empty g q = q +beside Empty _ q = q beside (Nest k p) g q = nest_ k $! beside p g q -- p non-empty beside p@(Beside p1 g1 q1) g2 q2 {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2 @@ -655,7 +666,7 @@ beside (TextBeside s sl p) g q = textBeside_ s sl $! rest where rest = case p of Empty -> nilBeside g q - other -> beside p g q + _ -> beside p g q \end{code} \begin{code} @@ -663,17 +674,17 @@ nilBeside :: Bool -> RDoc -> RDoc -- Specification: text "" <> nilBeside g p -- = text "" p -nilBeside g Empty = Empty -- Hence the text "" in the spec +nilBeside _ Empty = Empty -- Hence the text "" in the spec nilBeside g (Nest _ p) = nilBeside g p nilBeside g p | g = textBeside_ space_text (_ILIT(1)) p | otherwise = p \end{code} -********************************************************* -* * +%********************************************************* +%* * \subsection{Separate, @sep@, Hughes version} -* * -********************************************************* +%* * +%********************************************************* \begin{code} -- Specification: sep ps = oneLiner (hsep ps) @@ -683,7 +694,8 @@ nilBeside g p | g = textBeside_ space_text (_ILIT(1)) p sep = sepX True -- Separate with spaces cat = sepX False -- Don't -sepX x [] = empty +sepX :: Bool -> [Doc] -> Doc +sepX _ [] = empty sepX x (p:ps) = sep1 x (reduceDoc p) (_ILIT(0)) ps @@ -692,7 +704,7 @@ sepX x (p:ps) = sep1 x (reduceDoc p) (_ILIT(0)) ps -- `union` x $$ nest k (vcat ys) sep1 :: Bool -> RDoc -> FastInt -> [Doc] -> RDoc -sep1 g NoDoc k ys = NoDoc +sep1 _ NoDoc _ _ = NoDoc sep1 g (p `Union` q) k ys = sep1 g p k ys `union_` (aboveNest q False k (reduceDoc (vcat ys))) @@ -700,13 +712,15 @@ sep1 g (p `Union` q) k ys = sep1 g p k ys sep1 g Empty k ys = mkNest k (sepX g ys) sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k -# n) ys) -sep1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys))) +sep1 _ (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys))) sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k -# sl) ys) +sep1 _ _ _ _ = panic "sep1: Unhandled case" -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys -- Called when we have already found some text in the first item -- We have to eat up nests +sepNB :: Bool -> Doc -> FastInt -> [Doc] -> Doc sepNB g (Nest _ p) k ys = sepNB g p k ys sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest)) @@ -719,11 +733,11 @@ sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest)) sepNB g p k ys = sep1 g p k ys \end{code} -********************************************************* -* * +%********************************************************* +%* * \subsection{@fill@} -* * -********************************************************* +%* * +%********************************************************* \begin{code} fsep = fill True @@ -737,12 +751,13 @@ fcat = fill False -- `union` -- p1 $$ fill ps -fill g [] = empty +fill :: Bool -> [Doc] -> Doc +fill _ [] = empty fill g (p:ps) = fill1 g (reduceDoc p) (_ILIT(0)) ps fill1 :: Bool -> RDoc -> FastInt -> [Doc] -> Doc -fill1 g NoDoc k ys = NoDoc +fill1 _ NoDoc _ _ = NoDoc fill1 g (p `Union` q) k ys = fill1 g p k ys `union_` (aboveNest q False k (fill g ys)) @@ -752,25 +767,27 @@ fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k -# n) ys) fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys)) fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k -# sl) ys) +fill1 _ _ _ _ = panic "fill1: Unhandled case" +fillNB :: Bool -> Doc -> Int# -> [Doc] -> Doc fillNB g (Nest _ p) k ys = fillNB g p k ys -fillNB g Empty k [] = Empty +fillNB _ Empty _ [] = Empty fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys) `mkUnion` nilAboveNest False k (fill g (y:ys)) where - k1 | g = k -# _ILIT(1) - | otherwise = k + !k1 | g = k -# _ILIT(1) + | otherwise = k fillNB g p k ys = fill1 g p k ys \end{code} -********************************************************* -* * +%********************************************************* +%* * \subsection{Selecting the best layout} -* * -********************************************************* +%* * +%********************************************************* \begin{code} best :: Int -- Line length @@ -781,30 +798,34 @@ best :: Int -- Line length best w_ r_ p = get (iUnbox w_) p where - r = iUnbox r_ + !r = iUnbox r_ get :: FastInt -- (Remaining) width of line -> Doc -> Doc - get w Empty = Empty - get w NoDoc = NoDoc + get _ Empty = Empty + get _ NoDoc = NoDoc get w (NilAbove p) = nilAbove_ (get w p) get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p) get w (Nest k p) = nest_ k (get (w -# k) p) get w (p `Union` q) = nicest w r (get w p) (get w q) + get _ _ = panic "best/get: Unhandled case" get1 :: FastInt -- (Remaining) width of line -> FastInt -- Amount of first line already eaten up -> Doc -- This is an argument to TextBeside => eat Nests -> Doc -- No unions in here! - get1 w sl Empty = Empty - get1 w sl NoDoc = NoDoc + get1 _ _ Empty = Empty + get1 _ _ NoDoc = NoDoc get1 w sl (NilAbove p) = nilAbove_ (get (w -# sl) p) get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl +# tl) p) - get1 w sl (Nest k p) = get1 w sl p + get1 w sl (Nest _ p) = get1 w sl p get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) (get1 w sl q) + get1 _ _ _ = panic "best/get1: Unhandled case" +nicest :: FastInt -> FastInt -> Doc -> Doc -> Doc nicest w r p q = nicest1 w r (_ILIT(0)) p q +nicest1 :: FastInt -> FastInt -> Int# -> Doc -> Doc -> Doc nicest1 w r sl p q | fits ((w `minFastInt` r) -# sl) p = p | otherwise = q @@ -812,26 +833,30 @@ fits :: FastInt -- Space available -> Doc -> Bool -- True if *first line* of Doc fits in space available -fits n p | n <# _ILIT(0) = False -fits n NoDoc = False -fits n Empty = True -fits n (NilAbove _) = True +fits n _ | n <# _ILIT(0) = False +fits _ NoDoc = False +fits _ Empty = True +fits _ (NilAbove _) = True fits n (TextBeside _ sl p) = fits (n -# sl) p +fits _ _ = panic "fits: Unhandled case" \end{code} @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler. @first@ returns its first argument if it is non-empty, otherwise its second. \begin{code} +first :: Doc -> Doc -> Doc first p q | nonEmptySet p = p | otherwise = q +nonEmptySet :: Doc -> Bool nonEmptySet NoDoc = False -nonEmptySet (p `Union` q) = True +nonEmptySet (_ `Union` _) = True nonEmptySet Empty = True -nonEmptySet (NilAbove p) = True -- NoDoc always in first line +nonEmptySet (NilAbove _) = True -- NoDoc always in first line nonEmptySet (TextBeside _ _ p) = nonEmptySet p nonEmptySet (Nest _ p) = nonEmptySet p +nonEmptySet _ = panic "nonEmptySet: Unhandled case" \end{code} @oneLiner@ returns the one-line members of the given set of @Doc@s. @@ -840,19 +865,20 @@ nonEmptySet (Nest _ p) = nonEmptySet p oneLiner :: Doc -> Doc oneLiner NoDoc = NoDoc oneLiner Empty = Empty -oneLiner (NilAbove p) = NoDoc +oneLiner (NilAbove _) = NoDoc oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p) oneLiner (Nest k p) = nest_ k (oneLiner p) -oneLiner (p `Union` q) = oneLiner p +oneLiner (p `Union` _) = oneLiner p +oneLiner _ = panic "oneLiner: Unhandled case" \end{code} -********************************************************* -* * +%********************************************************* +%* * \subsection{Displaying the best layout} -* * -********************************************************* +%* * +%********************************************************* \begin{code} @@ -862,6 +888,8 @@ renderStyle Style{mode, lineLength, ribbonsPerLine} doc -} render doc = showDocWith PageMode doc + +showDoc :: Doc -> String -> String showDoc doc rest = showDocWithAppend PageMode doc rest showDocWithAppend :: Mode -> Doc -> String -> String @@ -870,6 +898,7 @@ showDocWithAppend mode doc rest = fullRender mode 100 1.5 string_txt rest doc showDocWith :: Mode -> Doc -> String showDocWith mode doc = showDocWithAppend mode doc "" +string_txt :: TextDetails -> String -> String string_txt (Chr c) s = c:s string_txt (Str s1) s2 = s1 ++ s2 string_txt (PStr s1) s2 = unpackFS s1 ++ s2 @@ -881,23 +910,25 @@ string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2 fullRender OneLineMode _ _ txt end doc = lay (reduceDoc doc) where - lay NoDoc = cant_fail - lay (Union p q) = (lay q) -- Second arg can't be NoDoc - lay (Nest k p) = lay p - lay Empty = end - lay (NilAbove p) = space_text `txt` lay p -- NoDoc always on - -- first line - lay (TextBeside s sl p) = s `txt` lay p + lay NoDoc = cant_fail + lay (Union _ q) = lay q -- Second arg can't be NoDoc + lay (Nest _ p) = lay p + lay Empty = end + lay (NilAbove p) = space_text `txt` lay p -- NoDoc always on + -- first line + lay (TextBeside s _ p) = s `txt` lay p + lay _ = panic "fullRender/OneLineMode/lay: Unhandled case" fullRender LeftMode _ _ txt end doc = lay (reduceDoc doc) where - lay NoDoc = cant_fail - lay (Union p q) = lay (first p q) - lay (Nest k p) = lay p - lay Empty = end - lay (NilAbove p) = nl_text `txt` lay p -- NoDoc always on first line - lay (TextBeside s sl p) = s `txt` lay p + lay NoDoc = cant_fail + lay (Union p q) = lay (first p q) + lay (Nest _ p) = lay p + lay Empty = end + lay (NilAbove p) = nl_text `txt` lay p -- NoDoc always on first line + lay (TextBeside s _ p) = s `txt` lay p + lay _ = panic "fullRender/LeftMode/lay: Unhandled case" fullRender mode line_length ribbons_per_line txt end doc = display mode line_length ribbon_length txt end best_doc @@ -906,14 +937,17 @@ fullRender mode line_length ribbons_per_line txt end doc hacked_line_length, ribbon_length :: Int ribbon_length = round (fromIntegral line_length / ribbons_per_line) - hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length } + hacked_line_length = case mode of + ZigZagMode -> maxBound + _ -> line_length +display :: Mode -> Int -> Int -> (TextDetails -> t -> t) -> t -> Doc -> t display mode page_width ribbon_width txt end doc = case (iUnbox page_width) -# (iUnbox ribbon_width) of { gap_width -> case gap_width `quotFastInt` _ILIT(2) of { shift -> let lay k (Nest k1 p) = lay (k +# k1) p - lay k Empty = end + lay _ Empty = end lay k (NilAbove p) = nl_text `txt` lay k p @@ -931,35 +965,41 @@ display mode page_width ribbon_width txt end doc nl_text `txt` ( lay1 (k +# shift) s sl p ))) - other -> lay1 k s sl p + _ -> lay1 k s sl p + lay _ _ = panic "display/lay: Unhandled case" lay1 k s sl p = indent k (s `txt` lay2 (k +# sl) p) lay2 k (NilAbove p) = nl_text `txt` lay k p lay2 k (TextBeside s sl p) = s `txt` (lay2 (k +# sl) p) lay2 k (Nest _ p) = lay2 k p - lay2 k Empty = end + lay2 _ Empty = end + lay2 _ _ = panic "display/lay2: Unhandled case" -- optimise long indentations using LitString chunks of 8 spaces - indent n r | n >=# _ILIT(8) = LStr SLIT(" ") (_ILIT(8)) `txt` + indent n r | n >=# _ILIT(8) = LStr (sLit " ") (_ILIT(8)) `txt` indent (n -# _ILIT(8)) r | otherwise = Str (spaces n) `txt` r in lay (_ILIT(0)) doc }} +cant_fail :: a cant_fail = error "easy_display: NoDoc" +multi_ch :: Int# -> Char -> String multi_ch n ch | n <=# _ILIT(0) = "" | otherwise = ch : multi_ch (n -# _ILIT(1)) ch +spaces :: Int# -> String spaces n | n <=# _ILIT(0) = "" | otherwise = ' ' : spaces (n -# _ILIT(1)) \end{code} \begin{code} -pprCols = (120 :: Int) -- could make configurable +pprCols :: Int +pprCols = 100 -- could make configurable printDoc :: Mode -> Handle -> Doc -> IO () printDoc LeftMode hdl doc @@ -970,12 +1010,15 @@ printDoc mode hdl doc where put (Chr c) next = hPutChar hdl c >> next put (Str s) next = hPutStr hdl s >> next - put (PStr s) next = hPutFS hdl s >> next + put (PStr s) next = hPutStr hdl (unpackFS s) >> next + -- NB. not hPutFS, we want this to go through + -- the I/O library's encoding layer. (#3398) put (LStr s l) next = hPutLitString hdl s l >> next done = hPutChar hdl '\n' -- some versions of hPutBuf will barf if the length is zero +hPutLitString :: Handle -> Ptr a -> Int# -> IO () hPutLitString handle a l = if l ==# _ILIT(0) then return () else hPutBuf handle a (iBox l) @@ -999,23 +1042,28 @@ hPutLitString handle a l = if l ==# _ILIT(0) printLeftRender :: Handle -> Doc -> IO () printLeftRender hdl doc = do b <- newBufHandle hdl - layLeft b (reduceDoc doc) + bufLeftRender b doc bFlush b +bufLeftRender :: BufHandle -> Doc -> IO () +bufLeftRender b doc = layLeft b (reduceDoc doc) + -- HACK ALERT! the "return () >>" below convinces GHC to eta-expand -- this function with the IO state lambda. Otherwise we end up with -- closures in all the case branches. -layLeft b _ | b `seq` False = undefined -- make it strict in b -layLeft b NoDoc = cant_fail -layLeft b (Union p q) = return () >> layLeft b (first p q) -layLeft b (Nest k p) = return () >> layLeft b p -layLeft b Empty = bPutChar b '\n' -layLeft b (NilAbove p) = bPutChar b '\n' >> layLeft b p -layLeft b (TextBeside s sl p) = put b s >> layLeft b p +layLeft :: BufHandle -> Doc -> IO () +layLeft b _ | b `seq` False = undefined -- make it strict in b +layLeft _ NoDoc = cant_fail +layLeft b (Union p q) = return () >> layLeft b (first p q) +layLeft b (Nest _ p) = return () >> layLeft b p +layLeft b Empty = bPutChar b '\n' +layLeft b (NilAbove p) = bPutChar b '\n' >> layLeft b p +layLeft b (TextBeside s _ p) = put b s >> layLeft b p where put b _ | b `seq` False = undefined put b (Chr c) = bPutChar b c put b (Str s) = bPutStr b s put b (PStr s) = bPutFS b s put b (LStr s l) = bPutLitString b s l +layLeft _ _ = panic "layLeft: Unhandled case" \end{code}