X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FPretty.lhs;h=317022d66927e819f57e1fb4df9f514f06d542c5;hp=bebb6b2df885fb479b5eb5bff8d95fa7782049de;hb=5289f5d85610f71625a439747a09384876655eb5;hpb=82dc0d197b39b6462d1a19e4c556f7acdf376ee9 diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs index bebb6b2..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,13 +152,18 @@ Relative to John's original paper, there are the following new features: \begin{code} +{-# 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 Mode(..), TextDetails(..), 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, @@ -172,11 +177,10 @@ 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 @@ -209,11 +213,11 @@ infixl 5 $$, $+$ \end{code} -********************************************************* -* * +%********************************************************* +%* * \subsection{The interface} -* * -********************************************************* +%* * +%********************************************************* The primitive @Doc@ values @@ -296,11 +300,11 @@ data Mode = PageMode -- Normal \end{code} -********************************************************* -* * +%********************************************************* +%* * \subsection{The @Doc@ calculus} -* * -********************************************************* +%* * +%********************************************************* The @Doc@ combinators satisfy the following laws: \begin{verbatim} @@ -334,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 ~~~~~~~~~~~~~ @@ -375,11 +379,11 @@ But it doesn't work, for if x=empty, we would have -********************************************************* -* * +%********************************************************* +%* * \subsection{Simple derived definitions} -* * -********************************************************* +%* * +%********************************************************* \begin{code} semi = char ';' @@ -425,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. @@ -529,7 +533,6 @@ union_ p q = Union (LOCAL_ASSERT( _ok p ) p) (LOCAL_ASSERT( _ok q ) q) _ok _ = False \end{code} - Notice the difference between * NoDoc (no documents) * Empty (one empty document; no height and no width) @@ -538,11 +541,11 @@ Notice the difference between -********************************************************* -* * +%********************************************************* +%* * \subsection{@empty@, @text@, @nest@, @union@} -* * -********************************************************* +%* * +%********************************************************* \begin{code} empty = Empty @@ -555,7 +558,7 @@ 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 :: LitString -> Doc -ptext s_= case iUnbox (strLength s) of {sl -> textBeside_ (LStr s sl) sl Empty} +ptext s_= case iUnbox (lengthLS s) of {sl -> textBeside_ (LStr s sl) sl Empty} where s = {-castPtr-} s_ #if defined(__GLASGOW_HASKELL__) @@ -582,11 +585,11 @@ mkUnion Empty _ = Empty mkUnion p q = p `union_` q \end{code} -********************************************************* -* * +%********************************************************* +%* * \subsection{Vertical composition @$$@} -* * -********************************************************* +%* * +%********************************************************* \begin{code} @@ -613,7 +616,7 @@ aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k -# k1) q) 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 _ -> aboveNest p g k1 q @@ -635,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 @@ -677,11 +680,11 @@ 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) @@ -730,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 @@ -773,18 +776,18 @@ 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 @@ -795,7 +798,7 @@ 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 _ Empty = Empty @@ -871,11 +874,11 @@ oneLiner _ = panic "oneLiner: Unhandled case" -********************************************************* -* * +%********************************************************* +%* * \subsection{Displaying the best layout} -* * -********************************************************* +%* * +%********************************************************* \begin{code} @@ -974,7 +977,7 @@ display mode page_width ribbon_width txt end doc 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 @@ -996,7 +999,7 @@ spaces n | n <=# _ILIT(0) = "" \begin{code} pprCols :: Int -pprCols = 120 -- could make configurable +pprCols = 100 -- could make configurable printDoc :: Mode -> Handle -> Doc -> IO () printDoc LeftMode hdl doc @@ -1007,7 +1010,9 @@ 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' @@ -1037,9 +1042,12 @@ 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.