From a1706e166ef400bab3b15a8fd80145ede6655c62 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Mon, 18 Feb 2008 10:53:43 +0000 Subject: [PATCH] Whitespace only --- compiler/utils/Pretty.lhs | 174 +++++++++++++++++++++++---------------------- 1 file changed, 88 insertions(+), 86 deletions(-) diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs index f1051b0..c4365a3 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) @@ -171,13 +171,13 @@ 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 @@ -194,13 +194,13 @@ import System.IO #if defined(__GLASGOW_HASKELL__) --for a RULES -import GHC.Base ( unpackCString# ) -import GHC.Ptr ( Ptr(..) ) +import GHC.Base ( unpackCString# ) +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} @@ -225,13 +225,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 @@ -268,7 +268,7 @@ 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 @@ -283,7 +283,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 @@ -293,7 +293,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 @@ -344,7 +344,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) @@ -362,14 +362,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 @@ -441,7 +441,7 @@ no occurrences of @Union@ or @NoDoc@ represents just one layout. data Doc = Empty -- empty | NilAbove Doc -- text "" $$ x - | TextBeside !TextDetails FastInt Doc -- text s <> 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 @@ -459,8 +459,9 @@ reduceDoc p = p data TextDetails = Chr {-#UNPACK#-}!Char | Str String - | PStr FastString -- a hashed string - | LStr {-#UNPACK#-}!LitString FastInt -- a '\0'-terminated array of bytes + | PStr FastString -- a hashed string + | LStr {-#UNPACK#-}!LitString FastInt -- a '\0'-terminated + -- array of bytes space_text = Chr ' ' nl_text = Chr '\n' @@ -475,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 @@ -486,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), @@ -556,7 +557,7 @@ ptext s_= case iUnbox (strLength s) of {sl -> textBeside_ (LStr s sl) sl Empty} #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 @@ -595,13 +596,13 @@ 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 (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 -# 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 @@ -613,7 +614,7 @@ aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest \begin{code} nilAboveNest :: Bool -> FastInt -> RDoc -> RDoc --- Specification: text s <> nilaboveNest g k q +-- 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! @@ -638,13 +639,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 (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q) beside Empty g 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 @@ -659,7 +660,7 @@ beside (TextBeside s sl p) g q = textBeside_ s sl $! rest \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 @@ -709,7 +710,7 @@ sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k -# sl) ys) 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 @@ -728,10 +729,10 @@ 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 @@ -755,7 +756,7 @@ fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k -# sl) ys) fillNB g (Nest _ p) k ys = fillNB g p k ys fillNB g Empty k [] = 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 -# _ILIT(1) @@ -800,7 +801,7 @@ best w_ r_ p 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 (p `Union` q) = nicest1 w r sl (get1 w sl p) + get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) (get1 w sl q) nicest w r p q = nicest1 w r (_ILIT(0)) p q @@ -810,7 +811,7 @@ nicest1 w r sl p q | fits ((w `minFastInt` r) -# sl) p = p 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 @@ -822,7 +823,7 @@ fits n (TextBeside _ sl p) = fits (n -# sl) p @first@ returns its first argument if it is non-empty, otherwise its second. \begin{code} -first p q | nonEmptySet p = p +first p q | nonEmptySet p = p | otherwise = q nonEmptySet NoDoc = False @@ -856,7 +857,7 @@ 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 "" -} @@ -877,29 +878,30 @@ string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2 \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 (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 (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 +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 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 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 @@ -912,9 +914,9 @@ display mode page_width ribbon_width txt end doc let lay k (Nest k1 p) = lay (k +# k1) p lay k Empty = end - + lay k (NilAbove p) = nl_text `txt` lay k p - + lay k (TextBeside s sl p) = case mode of ZigZagMode | k >=# gap_width @@ -930,16 +932,16 @@ display mode page_width ribbon_width txt end doc lay1 (k +# shift) s sl p ))) other -> lay1 k s sl p - + 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 -- 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 @@ -949,7 +951,7 @@ display mode page_width ribbon_width txt end doc cant_fail = error "easy_display: NoDoc" multi_ch n ch | n <=# _ILIT(0) = "" - | otherwise = ch : multi_ch (n -# _ILIT(1)) ch + | otherwise = ch : multi_ch (n -# _ILIT(1)) ch spaces n | n <=# _ILIT(0) = "" | otherwise = ' ' : spaces (n -# _ILIT(1)) @@ -964,12 +966,12 @@ 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' @@ -982,17 +984,17 @@ hPutLitString handle a l = if l ==# _ILIT(0) -- 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 @@ -1003,13 +1005,13 @@ 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 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 where put b _ | b `seq` False = undefined put b (Chr c) = bPutChar b c -- 1.7.10.4