X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Text%2FPrettyPrint%2FHughesPJ.hs;h=2b983a518f7459dea855ccde66453373fef9ff92;hb=180df3420fa0b46ffffc091946fe6ba6914df08a;hp=8b77da87519b9ddc8fb038f4f660e2e0e37cc8ff;hpb=9fa9bc17072a58c0bae2cce4764d38677e96ac29;p=ghc-base.git diff --git a/Text/PrettyPrint/HughesPJ.hs b/Text/PrettyPrint/HughesPJ.hs index 8b77da8..2b983a5 100644 --- a/Text/PrettyPrint/HughesPJ.hs +++ b/Text/PrettyPrint/HughesPJ.hs @@ -2,20 +2,18 @@ -- | -- Module : Text.PrettyPrint.HughesPJ -- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/core/LICENSE) +-- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : portable -- --- $Id: HughesPJ.hs,v 1.2 2002/04/24 16:31:47 simonmar Exp $ --- -- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators -- --- Based on "The Design of a Pretty-printing Library" +-- 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 -- @@ -88,7 +86,7 @@ Version 2.0 24 April 1997 nest k empty = empty which wasn't true before. - * Fixed an obscure bug in sep that occassionally gave very wierd behaviour + * Fixed an obscure bug in sep that occassionally gave very weird behaviour * Added $+$ @@ -104,7 +102,7 @@ Relative to John's original paper, there are the following new features: It is Really Useful in practice. 2. There is a paragraph-fill combinator, fsep, that's much like sep, - only it keeps fitting things on one line until itc can't fit any more. + only it keeps fitting things on one line until it can't fit any more. 3. Some random useful extra combinators are provided. <+> puts its arguments beside each other with a space between them, @@ -117,8 +115,8 @@ Relative to John's original paper, there are the following new features: sep (separate) is either like hsep or like vcat, depending on what fits - cat is behaves like sep, but it uses <> for horizontal conposition - fcat is behaves like fsep, but it uses <> for horizontal conposition + cat behaves like sep, but it uses <> for horizontal conposition + fcat behaves like fsep, but it uses <> for horizontal conposition These new ones do the obvious things: char, semi, comma, colon, space, @@ -170,26 +168,47 @@ Relative to John's original paper, there are the following new features: -} module Text.PrettyPrint.HughesPJ ( + + -- * The document type Doc, -- Abstract - Mode(..), TextDetails(..), - empty, isEmpty, nest, + -- * Primitive Documents + empty, + semi, comma, colon, space, equals, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, + -- * Converting values into documents text, char, ptext, int, integer, float, double, rational, + + -- * Wrapping documents in delimiters parens, brackets, braces, quotes, doubleQuotes, - semi, comma, colon, space, equals, - lparen, rparen, lbrack, rbrack, lbrace, rbrace, + -- * Combining documents (<>), (<+>), hcat, hsep, ($$), ($+$), vcat, sep, cat, fsep, fcat, - + nest, hang, punctuate, --- renderStyle, -- Haskell 1.3 only - render, fullRender + -- * Predicates on documents + isEmpty, + + -- * Rendering documents + + -- ** Default rendering + render, + + -- ** Rendering with a particular style + Style(..), + style, + renderStyle, + + -- ** General rendering + fullRender, + Mode(..), TextDetails(..), + ) where @@ -204,47 +223,61 @@ infixl 5 $$, $+$ -- The primitive Doc values -empty :: Doc -isEmpty :: Doc -> Bool -text :: String -> Doc -char :: Char -> Doc - -semi, comma, colon, space, equals :: Doc -lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc - -parens, brackets, braces :: Doc -> Doc -quotes, doubleQuotes :: Doc -> Doc - -int :: Int -> Doc -integer :: Integer -> Doc -float :: Float -> Doc -double :: Double -> Doc +isEmpty :: Doc -> Bool; -- ^ Returns 'True' if the document is empty + +empty :: Doc; -- ^ An empty document +semi :: Doc; -- ^ A ';' character +comma :: Doc; -- ^ A ',' character +colon :: Doc; -- ^ A ':' character +space :: Doc; -- ^ A space character +equals :: Doc; -- ^ A '=' character +lparen :: Doc; -- ^ A '(' character +rparen :: Doc; -- ^ A ')' character +lbrack :: Doc; -- ^ A '[' character +rbrack :: Doc; -- ^ A ']' character +lbrace :: Doc; -- ^ A '{' character +rbrace :: Doc; -- ^ A '}' character + +text :: String -> Doc +ptext :: String -> Doc +char :: Char -> Doc +int :: Int -> Doc +integer :: Integer -> Doc +float :: Float -> Doc +double :: Double -> Doc rational :: Rational -> Doc +parens :: Doc -> Doc; -- ^ Wrap document in @(...)@ +brackets :: Doc -> Doc; -- ^ Wrap document in @[...]@ +braces :: Doc -> Doc; -- ^ Wrap document in @{...}@ +quotes :: Doc -> Doc; -- ^ Wrap document in @\'...\'@ +doubleQuotes :: Doc -> Doc; -- ^ Wrap document in @\"...\"@ + -- Combining @Doc@ values -(<>) :: Doc -> Doc -> Doc -- Beside -hcat :: [Doc] -> Doc -- List version of <> -(<+>) :: Doc -> Doc -> Doc -- Beside, separated by space -hsep :: [Doc] -> Doc -- List version of <+> +(<>) :: Doc -> Doc -> Doc; -- ^Beside +hcat :: [Doc] -> Doc; -- ^List version of '<>' +(<+>) :: Doc -> Doc -> Doc; -- ^Beside, separated by space +hsep :: [Doc] -> Doc; -- ^List version of '<+>' -($$) :: Doc -> Doc -> Doc -- Above; if there is no - -- overlap it "dovetails" the two -vcat :: [Doc] -> Doc -- List version of $$ +($$) :: Doc -> Doc -> Doc; -- ^Above; if there is no + -- overlap it \"dovetails\" the two +($+$) :: Doc -> Doc -> Doc; -- ^Above, without dovetailing. +vcat :: [Doc] -> Doc; -- ^List version of '$$' -cat :: [Doc] -> Doc -- Either hcat or vcat -sep :: [Doc] -> Doc -- Either hsep or vcat -fcat :: [Doc] -> Doc -- ``Paragraph fill'' version of cat -fsep :: [Doc] -> Doc -- ``Paragraph fill'' version of sep +cat :: [Doc] -> Doc; -- ^ Either hcat or vcat +sep :: [Doc] -> Doc; -- ^ Either hsep or vcat +fcat :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of cat +fsep :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of sep -nest :: Int -> Doc -> Doc -- Nested +nest :: Int -> Doc -> Doc; -- ^ Nested -- GHC-specific ones. -hang :: Doc -> Int -> Doc -> Doc -punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn] +hang :: Doc -> Int -> Doc -> Doc; -- ^ @hang d1 n d2 = sep [d1, nest n d2]@ +punctuate :: Doc -> [Doc] -> [Doc]; -- ^ @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ -- Displaying @Doc@ values. @@ -252,30 +285,37 @@ punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, instance Show Doc where showsPrec prec doc cont = showDoc doc cont -render :: Doc -> String -- Uses default style -fullRender :: Mode - -> Int -- Line length - -> Float -- Ribbons per line - -> (TextDetails -> a -> a) -- What to do with text - -> a -- What to do at the end - -> Doc - -> a -- Result +-- | Renders the document as a string using the default style +render :: Doc -> String -{- When we start using 1.3 +-- | The general rendering interface +fullRender :: Mode -- ^Rendering mode + -> Int -- ^Line length + -> Float -- ^Ribbons per line + -> (TextDetails -> a -> a) -- ^What to do with text + -> a -- ^What to do at the end + -> Doc -- ^The document + -> a -- ^Result + +-- | Render the document as a string using a specified style renderStyle :: Style -> Doc -> String -data Style = Style { lineLength :: Int, -- In chars - ribbonsPerLine :: Float, -- Ratio of ribbon length to line length - mode :: Mode - } -style :: Style -- The default style -style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode } --} -data Mode = PageMode -- Normal - | ZigZagMode -- With zig-zag cuts - | LeftMode -- No indentation, infinitely long lines - | OneLineMode -- All on one line +-- | A rendering style +data Style + = Style { mode :: Mode -- ^ The rendering mode + , lineLength :: Int -- ^ Length of line, in chars + , ribbonsPerLine :: Float -- ^ Ratio of ribbon length to line length + } + +-- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@) +style :: Style +style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode } +-- | Rendering mode +data Mode = PageMode -- ^Normal + | ZigZagMode -- ^With zig-zag cuts + | LeftMode -- ^No indentation, infinitely long lines + | OneLineMode -- ^All on one line -- --------------------------------------------------------------------------- -- The Doc calculus @@ -373,7 +413,7 @@ rational n = text (show n) -- SIGBJORN wrote instead: -- rational n = text (show (fromRationalX n)) -quotes p = char '`' <> p <> char '\'' +quotes p = char '\'' <> p <> char '\'' doubleQuotes p = char '"' <> p <> char '"' parens p = char '(' <> p <> char ')' brackets p = char '[' <> p <> char ']' @@ -398,6 +438,7 @@ punctuate p (d:ds) = go d ds -- A Doc represents a *set* of layouts. A Doc with -- no occurrences of Union or NoDoc represents just one layout. +-- | The abstract type of documents data Doc = Empty -- empty | NilAbove Doc -- text "" $$ x @@ -423,32 +464,33 @@ data TextDetails = Chr Char space_text = Chr ' ' nl_text = Chr '\n' --- Here are the invariants: - --- * The argument of NilAbove is never Empty. Therefore --- a NilAbove occupies at least two lines. --- --- * The arugment of @TextBeside@ is never @Nest@. --- --- --- * The layouts of the two arguments of @Union@ both flatten to the same --- string. --- --- * The arguments of @Union@ are either @TextBeside@, or @NilAbove@. --- --- * 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. - --- * An empty document is always represented by @Empty@. It can't be --- hidden inside a @Nest@, or a @Union@ of two @Empty@s. - --- * 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), this invariant means that the right argument must have at --- least two lines. - +{- + Here are the invariants: + + * The argument of NilAbove is never Empty. Therefore + a NilAbove occupies at least two lines. + + * The arugment of @TextBeside@ is never @Nest@. + + + * The layouts of the two arguments of @Union@ both flatten to the same + string. + + * The arguments of @Union@ are either @TextBeside@, or @NilAbove@. + + * 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. + + * An empty document is always represented by @Empty@. It can't be + hidden inside a @Nest@, or a @Union@ of two @Empty@s. + + * 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), this invariant means that the right argument must have at + least two lines. +-} -- Arg of a NilAbove is always an RDoc nilAbove_ p = NilAbove p @@ -757,10 +799,13 @@ oneLiner (p `Union` q) = oneLiner p -- --------------------------------------------------------------------------- -- Displaying the best layout -{- -renderStyle Style{mode, lineLength, ribbonsPerLine} doc - = fullRender mode lineLength ribbonsPerLine doc "" --} +renderStyle style doc + = fullRender (mode style) + (lineLength style) + (ribbonsPerLine style) + string_txt + "" + doc render doc = showDoc doc "" showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc @@ -831,12 +876,41 @@ easy_display nl_text txt end doc lay (NilAbove p) no_doc = nl_text `txt` lay p cant_fail -- NoDoc always on first line lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc -indent n | n >= 8 = '\t' : indent (n - 8) - | otherwise = spaces n +-- OLD version: we shouldn't rely on tabs being 8 columns apart in the output. +-- indent n | n >= 8 = '\t' : indent (n - 8) +-- | otherwise = spaces n +indent n = spaces n multi_ch 0 ch = "" multi_ch n ch = ch : multi_ch (n - 1) ch -spaces 0 = "" -spaces n = ' ' : spaces (n - 1) - +-- (spaces n) generates a list of n spaces +-- +-- It should never be called with 'n' < 0, but that can happen for reasons I don't understand +-- Here's a test case: +-- ncat x y = nest 4 $ cat [ x, y ] +-- d1 = foldl1 ncat $ take 50 $ repeat $ char 'a' +-- d2 = parens $ sep [ d1, text "+" , d1 ] +-- main = print d2 +-- I don't feel motivated enough to find the Real Bug, so meanwhile we just test for n<=0 +spaces n | n <= 0 = "" + | otherwise = ' ' : spaces (n - 1) + +{- Comments from Johannes Waldmann about what the problem might be: + + In the example above, d2 and d1 are deeply nested, but `text "+"' is not, + so the layout function tries to "out-dent" it. + + when I look at the Doc values that are generated, there are lots of + Nest constructors with negative arguments. see this sample output of + d1 (obtained with hugs, :s -u) + + tBeside (TextDetails_Chr 'a') 1 Doc_Empty) (Doc_NilAbove (Doc_Nest + (-241) (Doc_TextBeside (TextDetails_Chr 'a') 1 Doc_Empty))))) + (Doc_NilAbove (Doc_Nest (-236) (Doc_TextBeside (TextDetails_Chr 'a') 1 + (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside (TextDetails_Chr 'a') 1 + Doc_Empty)))))))) (Doc_NilAbove (Doc_Nest (-231) (Doc_TextBeside + (TextDetails_Chr 'a') 1 (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside + (TextDetails_Chr 'a') 1 (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside + (TextDetails_Chr 'a') 1 Doc_Empty))))))))))) (Doc_NilAbove (Doc_Nest +-}