X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FPretty.lhs;h=7713d03cfcb88c900c10406c10584659f50234f4;hp=51ecf31845229a67ee20c9b4e4e6e5c53f4b20f3;hb=9412e62942ebab0599c7fb0b358a9d4869647b67;hpb=01ecefa4b97106fec5c139c5514e5d56e59ecbaf diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs index 51ecf31..7713d03 100644 --- a/compiler/utils/Pretty.lhs +++ b/compiler/utils/Pretty.lhs @@ -23,13 +23,13 @@ Version 3.0 28 May 1997 certainly guarantee is insensivity to associativity. It matters: suddenly GHC's compilation times went up by a factor of 100 when I switched to the new pretty printer. - + I fixed it with a bit of a hack (because I wanted to get GHC back on the road). I added two new constructors to the Doc type, Above and Beside: - + <> = Beside $$ = Above - + Then, where I need to get to a "TextBeside" or "NilAbove" form I "force" the Doc to squeeze out these suspended calls to Beside and Above; but in so doing I re-associate. It's quite simple, but I'm not satisfied that I've done @@ -80,7 +80,7 @@ Version 2.0 24 April 1997 ====================================================================== Relative to John's original paper, there are the following new features: -1. There's an empty document, "empty". It's a left and right unit for +1. There's an empty document, "empty". It's a left and right unit for both <> and $$, and anywhere in the argument list for sep, hcat, hsep, vcat, fcat etc. @@ -89,7 +89,7 @@ Relative to John's original paper, there are the following new features: 2. There is a paragraph-fill combinator, fsep, that's much like sep, only it keeps fitting things on one line until it can't fit any more. -3. Some random useful extra combinators are provided. +3. Some random useful extra combinators are provided. <+> puts its arguments beside each other with a space between them, unless either argument is empty in which case it returns the other @@ -105,9 +105,9 @@ Relative to John's original paper, there are the following new features: These new ones do the obvious things: char, semi, comma, colon, space, - parens, brackets, braces, + parens, brackets, braces, quotes, doubleQuotes - + 4. The "above" combinator, $$, now overlaps its two arguments if the last line of the top argument stops before the first line of the second begins. For example: text "hi" $$ nest 5 "there" @@ -141,7 +141,7 @@ Relative to John's original paper, there are the following new features: 5. Several different renderers are provided: * a standard one - * one that uses cut-marks to avoid deeply-nested documents + * one that uses cut-marks to avoid deeply-nested documents simply piling up in the right-hand margin * one that ignores indentation (fewer chars output; good for machines) * one that ignores indentation and newlines (ditto, only more so) @@ -152,6 +152,10 @@ Relative to John's original paper, there are the following new features: \begin{code} +{-# 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(..), @@ -164,96 +168,46 @@ module Pretty ( semi, comma, colon, space, equals, lparen, rparen, lbrack, rbrack, lbrace, rbrace, cparen, - (<>), (<+>), hcat, hsep, - ($$), ($+$), vcat, - sep, cat, - fsep, fcat, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, hang, punctuate, - + -- renderStyle, -- Haskell 1.3 only render, fullRender, printDoc, showDocWith ) where -#include "HsVersions.h" - import BufWrite import FastString - -import GHC.Exts +import FastTypes +import Panic import Numeric (fromRat) import System.IO +--import Foreign.Ptr (castPtr) -import GHC.Base ( unpackCString# ) -import GHC.Ptr ( Ptr(..) ) +#if defined(__GLASGOW_HASKELL__) +--for a RULES +import GHC.Base ( unpackCString# ) +import GHC.Exts ( Int# ) +import GHC.Ptr ( Ptr(..) ) +#endif -- Don't import Util( assertPanic ) because it makes a loop in the module structure -infixl 6 <> +infixl 6 <> infixl 6 <+> infixl 5 $$, $+$ \end{code} - -********************************************************* -* * -\subsection{CPP magic so that we can compile with both GHC and Hugs} -* * -********************************************************* - -The library uses unboxed types to get a bit more speed, but these CPP macros -allow you to use either GHC or Hugs. To get GHC, just set the CPP variable - __GLASGOW_HASKELL__ - \begin{code} -#if defined(__GLASGOW_HASKELL__) - --- Glasgow Haskell - -- Disable ASSERT checks; they are expensive! #define LOCAL_ASSERT(x) -#define ILIT(x) (x#) -#define IBOX(x) (I# (x)) -#define INT Int# -#define MINUS -# -#define NEGATE negateInt# -#define PLUS +# -#define GR ># -#define GREQ >=# -#define LT <# -#define LTEQ <=# -#define DIV `quotInt#` - - -#define SHOW Show -#define MAXINT maxBound - -#else - --- Standard Haskell - -#define LOCAL_ASSERT(x) - -#define INT Int -#define IBOX(x) x -#define MINUS - -#define NEGATE negate -#define PLUS + -#define GR > -#define GREQ >= -#define LT < -#define DIV `quot` -#define ILIT(x) x - -#define SHOW Show -#define MAXINT maxBound - -#endif - \end{code} @@ -268,13 +222,13 @@ The primitive @Doc@ values \begin{code} empty :: Doc isEmpty :: Doc -> Bool -text :: String -> Doc +text :: String -> Doc char :: Char -> Doc semi, comma, colon, space, equals :: Doc lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc -parens, brackets, braces :: Doc -> Doc +parens, brackets, braces :: Doc -> Doc quotes, doubleQuotes :: Doc -> Doc int :: Int -> Doc @@ -311,11 +265,11 @@ hang :: Doc -> Int -> Doc -> Doc punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn] \end{code} -Displaying @Doc@ values. +Displaying @Doc@ values. \begin{code} -instance SHOW Doc where - showsPrec prec doc cont = showDoc doc cont +instance Show Doc where + showsPrec _ doc cont = showDoc doc cont render :: Doc -> String -- Uses default style fullRender :: Mode @@ -326,7 +280,7 @@ fullRender :: Mode -> Doc -> a -- Result -{- When we start using 1.3 +{- When we start using 1.3 renderStyle :: Style -> Doc -> String data Style = Style { lineLength :: Int, -- In chars ribbonsPerLine :: Float, -- Ratio of ribbon length to line length @@ -336,7 +290,7 @@ style :: Style -- The default style style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode } -} -data Mode = PageMode -- Normal +data Mode = PageMode -- Normal | ZigZagMode -- With zig-zag cuts | LeftMode -- No indentation, infinitely long lines | OneLineMode -- All on one line @@ -387,7 +341,7 @@ Laws for nest Miscellaneous ~~~~~~~~~~~~~ - (text s <> x) $$ y = text s <> ((text "" <> x)) $$ + (text s <> x) $$ y = text s <> ((text "" <> x)) $$ nest (-length s) y) (x $$ y) <> z = x $$ (y <> z) @@ -405,14 +359,14 @@ Laws for list versions Laws for oneLiner ~~~~~~~~~~~~~~~~~ oneLiner (nest k p) = nest k (oneLiner p) - oneLiner (x <> y) = oneLiner x <> oneLiner y + oneLiner (x <> y) = oneLiner x <> oneLiner y \end{verbatim} You might think that the following verion of would be neater: \begin{verbatim} -<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ +<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ nest (-length s) y) \end{verbatim} But it doesn't work, for if x=empty, we would have @@ -455,6 +409,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 @@ -464,7 +419,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] @@ -484,8 +439,8 @@ no occurrences of @Union@ or @NoDoc@ represents just one layout. data Doc = Empty -- empty | NilAbove Doc -- text "" $$ x - | TextBeside !TextDetails INT Doc -- text s <> x - | Nest INT Doc -- nest k x + | TextBeside !TextDetails FastInt Doc -- text s <> x + | Nest FastInt Doc -- nest k x | Union Doc Doc -- ul `union` ur | NoDoc -- The empty set of documents | Beside Doc Bool Doc -- True <=> space between @@ -502,10 +457,13 @@ reduceDoc p = p data TextDetails = Chr {-#UNPACK#-}!Char | Str String - | PStr FastString -- a hashed string - | LStr Addr# Int# -- a '\0'-terminated array of bytes + | PStr FastString -- a hashed string + | 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} @@ -518,10 +476,10 @@ a @NilAbove@ occupies at least two lines. \item The arugment of @TextBeside@ is never @Nest@. -\item +\item The layouts of the two arguments of @Union@ both flatten to the same string. -\item +\item The arguments of @Union@ are either @TextBeside@, or @NilAbove@. \item @@ -529,11 +487,11 @@ The right argument of a union cannot be equivalent to the empty set (@NoDoc@). If the left argument of a union is equivalent to the empty set (@NoDoc@), then the @NoDoc@ appears in the first line. -\item +\item An empty document is always represented by @Empty@. It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s. -\item +\item The first line of every layout in the left argument of @Union@ is longer than the first line of any layout in the right argument. (1) ensures that the left argument has a first line. In view of (3), @@ -542,31 +500,35 @@ 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} @@ -590,28 +552,35 @@ empty = Empty isEmpty Empty = True isEmpty _ = False -char c = textBeside_ (Chr c) 1# Empty -text s = case length s of {IBOX(sl) -> textBeside_ (Str s) sl Empty} -ftext s = case lengthFS s of {IBOX(sl) -> textBeside_ (PStr s) sl Empty} -ptext (Ptr s) = case strLength (Ptr s) of {IBOX(sl) -> textBeside_ (LStr s sl) sl Empty} +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 :: LitString -> Doc +ptext s_= case iUnbox (strLength s) of {sl -> textBeside_ (LStr s sl) sl Empty} + where s = {-castPtr-} s_ +#if defined(__GLASGOW_HASKELL__) -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the -- intermediate packing/unpacking of the string. -{-# RULES +{-# RULES "text/str" forall a. text (unpackCString# a) = ptext (Ptr a) #-} +#endif -nest IBOX(k) p = mkNest k (reduceDoc p) -- Externally callable version +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 k (Nest k1 p) = mkNest (k PLUS k1) p -mkNest k NoDoc = NoDoc -mkNest k Empty = Empty -mkNest ILIT(0) p = p -- Worth a try! +mkNest :: Int# -> Doc -> Doc +mkNest k (Nest k1 p) = mkNest (k +# k1) p +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} @@ -624,42 +593,44 @@ mkUnion p q = p `union_` q \begin{code} p $$ q = Above p False q +($+$) :: Doc -> Doc -> Doc p $+$ q = Above p True q above :: Doc -> Bool -> RDoc -> RDoc above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2) -above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g ILIT(0) (reduceDoc q) -above p g q = aboveNest p g ILIT(0) (reduceDoc q) +above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g (_ILIT(0)) (reduceDoc q) +above p g q = aboveNest p g (_ILIT(0)) (reduceDoc q) -aboveNest :: RDoc -> Bool -> INT -> RDoc -> RDoc +aboveNest :: RDoc -> Bool -> FastInt -> RDoc -> RDoc -- Specfication: aboveNest p g k q = p $g$ (nest k q) -aboveNest NoDoc g k q = NoDoc -aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` +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 (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k MINUS k1) 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 MINUS 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} -nilAboveNest :: Bool -> INT -> RDoc -> RDoc --- Specification: text s <> nilaboveNest g k q +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 g k (Nest k1 q) = nilAboveNest g (k PLUS k1) q +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 GR ILIT(0)) -- No newline if no overlap +nilAboveNest g k q | (not g) && (k ># _ILIT(0)) -- No newline if no overlap = textBeside_ (Str (spaces k)) k q | otherwise -- Put them really above = nilAbove_ (mkNest k q) @@ -678,13 +649,13 @@ 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 +beside p@(Beside p1 g1 q1) g2 q2 + {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2 [ && (op1 == <> || op1 == <+>) ] -} | g1 == g2 = beside p1 g1 $! beside q1 g2 q2 | otherwise = beside (reduceDoc p) g2 q2 @@ -694,17 +665,17 @@ 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} nilBeside :: Bool -> RDoc -> RDoc --- Specification: text "" <> nilBeside g p +-- 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 +nilBeside g p | g = textBeside_ space_text (_ILIT(1)) p | otherwise = p \end{code} @@ -722,34 +693,37 @@ 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 x (p:ps) = sep1 x (reduceDoc p) ILIT(0) ps +sepX :: Bool -> [Doc] -> Doc +sepX _ [] = empty +sepX x (p:ps) = sep1 x (reduceDoc p) (_ILIT(0)) ps -- Specification: sep1 g k ys = sep (x : map (nest k) ys) -- = oneLiner (x nest k (hsep ys)) -- `union` x $$ nest k (vcat ys) -sep1 :: Bool -> RDoc -> INT -> [Doc] -> RDoc -sep1 g NoDoc k ys = NoDoc +sep1 :: Bool -> RDoc -> FastInt -> [Doc] -> RDoc +sep1 _ NoDoc _ _ = NoDoc sep1 g (p `Union` q) k ys = sep1 g p k ys `union_` (aboveNest q False k (reduceDoc (vcat ys))) sep1 g Empty k ys = mkNest k (sepX g ys) -sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k MINUS n) 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 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k MINUS sl) 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)) - `mkUnion` + `mkUnion` nilAboveNest False k (reduceDoc (vcat ys)) where rest | g = hsep ys @@ -768,37 +742,40 @@ sepNB g p k ys = sep1 g p k ys fsep = fill True fcat = fill False --- Specification: +-- Specification: -- fill [] = empty -- fill [p] = p --- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) +-- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) -- (fill (oneLiner p2 : ps)) -- `union` -- p1 $$ fill ps -fill g [] = empty -fill g (p:ps) = fill1 g (reduceDoc p) ILIT(0) ps +fill :: Bool -> [Doc] -> Doc +fill _ [] = empty +fill g (p:ps) = fill1 g (reduceDoc p) (_ILIT(0)) ps -fill1 :: Bool -> RDoc -> INT -> [Doc] -> Doc -fill1 g NoDoc k ys = NoDoc +fill1 :: Bool -> RDoc -> FastInt -> [Doc] -> Doc +fill1 _ NoDoc _ _ = NoDoc fill1 g (p `Union` q) k ys = fill1 g p k ys `union_` (aboveNest q False k (fill g ys)) fill1 g Empty k ys = mkNest k (fill g ys) -fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k MINUS n) ys) +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 MINUS sl) 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` + `mkUnion` nilAboveNest False k (fill g (y:ys)) where - k1 | g = k MINUS ILIT(1) + k1 | g = k -# _ILIT(1) | otherwise = k fillNB g p k ys = fill1 g p k ys @@ -817,62 +794,68 @@ best :: Int -- Line length -> RDoc -> RDoc -- No unions in here! -best IBOX(w) IBOX(r) p - = get w p +best w_ r_ p + = get (iUnbox w_) p where - get :: INT -- (Remaining) width of line + 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 MINUS k) 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 :: INT -- (Remaining) width of line - -> INT -- Amount of first line already eaten up + 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 w sl (NilAbove p) = nilAbove_ (get (w MINUS sl) p) - get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl PLUS tl) p) - get1 w sl (Nest k p) = get1 w sl p - get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) + 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 _ 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 w r p q = nicest1 w r ILIT(0) p q -nicest1 w r sl p q | fits ((w `minn` r) MINUS sl) p = p +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 -fits :: INT -- Space available +fits :: FastInt -- Space available -> Doc -> Bool -- True if *first line* of Doc fits in space available - -fits n p | n LT ILIT(0) = False -fits n NoDoc = False -fits n Empty = True -fits n (NilAbove _) = True -fits n (TextBeside _ sl p) = fits (n MINUS sl) p - -minn x y | x LT y = x - | otherwise = y + +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 p q | nonEmptySet p = p +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. @@ -881,10 +864,11 @@ 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} @@ -898,11 +882,13 @@ oneLiner (p `Union` q) = oneLiner p \begin{code} {- -renderStyle Style{mode, lineLength, ribbonsPerLine} doc +renderStyle Style{mode, lineLength, ribbonsPerLine} doc = fullRender 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 @@ -911,136 +897,148 @@ 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 string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2 - -unpackLitString addr = - unpack 0# - where - unpack nh - | ch `eqChar#` '\0'# = [] - | otherwise = C# ch : unpack (nh +# 1#) - where - ch = indexCharOffAddr# addr nh \end{code} \begin{code} -fullRender OneLineMode _ _ txt end doc +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 - -fullRender LeftMode _ _ txt end doc + 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 - where + where best_doc = best hacked_line_length ribbon_length (reduceDoc doc) hacked_line_length, ribbon_length :: Int ribbon_length = round (fromIntegral line_length / ribbons_per_line) - hacked_line_length = case mode of { ZigZagMode -> MAXINT; other -> line_length } - -display mode IBOX(page_width) IBOX(ribbon_width) txt end doc - = case page_width MINUS ribbon_width of { gap_width -> - case gap_width DIV ILIT(2) of { shift -> + 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 PLUS k1) p - lay k Empty = end - + lay k (Nest k1 p) = lay (k +# k1) p + lay _ Empty = end + lay k (NilAbove p) = nl_text `txt` lay k p - + lay k (TextBeside s sl p) = case mode of - ZigZagMode | k GREQ gap_width + ZigZagMode | k >=# gap_width -> nl_text `txt` ( Str (multi_ch shift '/') `txt` ( nl_text `txt` ( - lay1 (k MINUS shift) s sl p))) + lay1 (k -# shift) s sl p))) - | k LT ILIT(0) + | k <# _ILIT(0) -> nl_text `txt` ( Str (multi_ch shift '\\') `txt` ( nl_text `txt` ( - lay1 (k PLUS shift) s sl p ))) + lay1 (k +# shift) 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) - other -> lay1 k s sl p - - lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k PLUS sl) p) - lay2 k (NilAbove p) = nl_text `txt` lay k p - lay2 k (TextBeside s sl p) = s `txt` (lay2 (k PLUS sl) 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 -# _ILIT(8)) r + | otherwise = Str (spaces n) `txt` r in - lay ILIT(0) doc + lay (_ILIT(0)) doc }} +cant_fail :: a cant_fail = error "easy_display: NoDoc" -indent n | n GREQ ILIT(8) = '\t' : indent (n MINUS ILIT(8)) - | otherwise = spaces n +multi_ch :: Int# -> Char -> String +multi_ch n ch | n <=# _ILIT(0) = "" + | otherwise = ch : multi_ch (n -# _ILIT(1)) ch -multi_ch n ch | n LTEQ ILIT(0) = "" - | otherwise = ch : multi_ch (n MINUS ILIT(1)) ch +spaces :: Int# -> String +spaces n | n <=# _ILIT(0) = "" + | otherwise = ' ' : spaces (n -# _ILIT(1)) -spaces n | n LTEQ ILIT(0) = "" - | otherwise = ' ' : spaces (n MINUS ILIT(1)) \end{code} \begin{code} -pprCols = (120 :: Int) -- could make configurable +pprCols :: Int +pprCols = 100 -- could make configurable +-- NB. printDoc prints FastStrings in UTF-8: hPutFS below does no decoding. +-- This is what we usually want, because the IO library has no encoding +-- functionality, and we're assuming UTF-8 source code so we might as well +-- assume UTF-8 output too. printDoc :: Mode -> Handle -> Doc -> IO () printDoc LeftMode hdl doc = do { printLeftRender hdl doc; hFlush hdl } printDoc mode hdl doc = do { fullRender mode pprCols 1.5 put done doc ; - hFlush hdl } + hFlush hdl } 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 (LStr s l) next = hPutLitString hdl s l >> next + 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 (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 a# 0# = return () -hPutLitString handle a# l# - = hPutBuf handle (Ptr a#) (I# l#) +hPutLitString :: Handle -> Ptr a -> Int# -> IO () +hPutLitString handle a l = if l ==# _ILIT(0) + then return () + else hPutBuf handle a (iBox l) -- Printing output in LeftMode is performance critical: it's used when -- dumping C and assembly output, so we allow ourselves a few dirty -- hacks: -- --- (1) we specialise fullRender for LeftMode with IO output. +-- (1) we specialise fullRender for LeftMode with IO output. -- --- (2) we add a layer of buffering on top of Handles. Handles --- don't perform well with lots of hPutChars, which is mostly --- what we're doing here, because Handles have to be thread-safe --- and async exception-safe. We only have a single thread and don't --- care about exceptions, so we add a layer of fast buffering --- over the Handle interface. +-- (2) we add a layer of buffering on top of Handles. Handles +-- don't perform well with lots of hPutChars, which is mostly +-- what we're doing here, because Handles have to be thread-safe +-- and async exception-safe. We only have a single thread and don't +-- care about exceptions, so we add a layer of fast buffering +-- over the Handle interface. -- --- (3) a few hacks in layLeft below to convince GHC to generate the right --- code. +-- (3) a few hacks in layLeft below to convince GHC to generate the right +-- code. printLeftRender :: Handle -> Doc -> IO () printLeftRender hdl doc = do @@ -1051,17 +1049,19 @@ printLeftRender hdl doc = do -- 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}