diff --git a/Text/PrettyPrint.hs b/Text/PrettyPrint.hs --- a/Text/PrettyPrint.hs +++ b/Text/PrettyPrint.hs @@ -4,18 +4,64 @@ -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file libraries/base/LICENSE) -- --- Maintainer : libraries@haskell.org --- Stability : experimental +-- Maintainer : David Terei +-- Stability : stable -- Portability : portable -- --- Re-export of "Text.PrettyPrint.HughesPJ" to provide a default --- pretty-printing library. Marked experimental at the moment; the --- default library might change at a later date. +-- The default interface to the pretty-printing library. Provides a collection +-- of pretty printer combinators. -- +-- This module should be used as opposed to the "Text.PrettyPrint.HughesPJ" +-- module. Both are equivalent though as this module simply re-exports the +-- other. +-- ----------------------------------------------------------------------------- module Text.PrettyPrint ( - module Text.PrettyPrint.HughesPJ - ) where + -- * The document type + Doc, + + -- * Constructing documents + + -- ** Converting values into documents + char, text, ptext, sizedText, zeroWidthText, + int, integer, float, double, rational, + + -- ** Simple derived documents + semi, comma, colon, space, equals, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, + + -- ** Wrapping documents in delimiters + parens, brackets, braces, quotes, doubleQuotes, + + -- ** Combining documents + empty, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + nest, + hang, punctuate, + + -- * Predicates on documents + isEmpty, + + -- * Rendering documents + + -- ** Default rendering + render, + + -- ** Rendering with a particular style + Style(..), + style, + renderStyle, + + -- ** General rendering + fullRender, + Mode(..), TextDetails(..) + + ) where + import Text.PrettyPrint.HughesPJ + diff --git a/Text/PrettyPrint/HughesPJ.hs b/Text/PrettyPrint/HughesPJ.hs --- a/Text/PrettyPrint/HughesPJ.hs +++ b/Text/PrettyPrint/HughesPJ.hs @@ -1,21 +1,22 @@ +{-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- -- | -- Module : Text.PrettyPrint.HughesPJ -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : provisional +-- +-- Maintainer : David Terei +-- Stability : stable -- Portability : portable -- -- 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 -- -- --- Heavily modified by Simon Peyton Jones, Dec 96 +-- Heavily modified by Simon Peyton Jones (December 1996). -- ----------------------------------------------------------------------------- @@ -30,7 +31,7 @@ chains. This is really bad news. One thing a pretty-printer abstraction - should certainly guarantee is insensivity to associativity. It + should certainly guarantee is insensitivity to associativity. It matters: suddenly GHC's compilation times went up by a factor of 100 when I switched to the new pretty printer. @@ -95,7 +96,7 @@ ====================================================================== 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. @@ -104,7 +105,7 @@ 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 @@ -115,12 +116,12 @@ sep (separate) is either like hsep or like vcat, depending on what fits - cat behaves like sep, but it uses <> for horizontal conposition - fcat behaves like fsep, but it uses <> for horizontal conposition + cat behaves like sep, but it uses <> for horizontal composition + fcat behaves like fsep, but it uses <> for horizontal composition 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 @@ -158,10 +159,12 @@ 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) + * one that ignores indentation + (fewer chars output; good for machines) + * one that ignores indentation and newlines + (ditto, only more so) 6. Numerous implementation tidy-ups Use of unboxed data types to speed up the implementation @@ -169,53 +172,56 @@ module Text.PrettyPrint.HughesPJ ( - -- * The document type - Doc, -- Abstract + -- * The document type + Doc, - -- * Constructing documents - -- ** Converting values into documents - char, text, ptext, zeroWidthText, + -- * Constructing documents + + -- ** Converting values into documents + char, text, ptext, sizedText, zeroWidthText, int, integer, float, double, rational, - -- ** Simple derived documents + -- ** Simple derived documents semi, comma, colon, space, equals, lparen, rparen, lbrack, rbrack, lbrace, rbrace, - -- ** Wrapping documents in delimiters + -- ** Wrapping documents in delimiters parens, brackets, braces, quotes, doubleQuotes, - -- ** Combining documents + -- ** Combining documents empty, - (<>), (<+>), hcat, hsep, - ($$), ($+$), vcat, - sep, cat, - fsep, fcat, - nest, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + nest, hang, punctuate, - - -- * Predicates on documents - isEmpty, - -- * Rendering documents + -- * Predicates on documents + isEmpty, - -- ** Default rendering - render, + -- * Rendering documents - -- ** Rendering with a particular style - Style(..), - style, + -- ** Default rendering + render, + + -- ** Rendering with a particular style + Style(..), + style, renderStyle, - -- ** General rendering + -- ** General rendering fullRender, - Mode(..), TextDetails(..), + Mode(..), TextDetails(..) - ) where + ) where import Prelude +import Data.Monoid ( Monoid(mempty, mappend) ) +import Data.String ( IsString(fromString) ) -infixl 6 <> +infixl 6 <> infixl 6 <+> infixl 5 $$, $+$ @@ -231,20 +237,20 @@ -- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc. empty :: Doc -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 +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 -- | A document of height and width 1, containing a literal character. -char :: Char -> Doc +char :: Char -> Doc -- | A document of height 1 containing a literal string. -- 'text' satisfies the following laws: @@ -255,29 +261,39 @@ -- -- The side condition on the last law is necessary because @'text' \"\"@ -- has height 1, while 'empty' has no height. -text :: String -> Doc +text :: String -> Doc +instance IsString Doc where + fromString = text + -- | An obsolete function, now identical to 'text'. -ptext :: String -> Doc +ptext :: String -> Doc +-- | Some text with any width. (@text s = sizedText (length s) s@) +sizedText :: Int -> String -> Doc + -- | Some text, but without any width. Use for non-printing text -- such as a HTML or Latex tags zeroWidthText :: String -> Doc -int :: Int -> Doc; -- ^ @int n = text (show n)@ -integer :: Integer -> Doc; -- ^ @integer n = text (show n)@ -float :: Float -> Doc; -- ^ @float n = text (show n)@ -double :: Double -> Doc; -- ^ @double n = text (show n)@ -rational :: Rational -> Doc; -- ^ @rational n = text (show n)@ +int :: Int -> Doc; -- ^ @int n = text (show n)@ +integer :: Integer -> Doc; -- ^ @integer n = text (show n)@ +float :: Float -> Doc; -- ^ @float n = text (show n)@ +double :: Double -> Doc; -- ^ @double n = text (show n)@ +rational :: Rational -> Doc; -- ^ @rational n = text (show n)@ -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 @\"...\"@ +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 +instance Monoid Doc where + mempty = empty + mappend = (<>) + -- | Beside. -- '<>' is associative, with identity 'empty'. (<>) :: Doc -> Doc -> Doc @@ -348,7 +364,7 @@ punctuate :: Doc -> [Doc] -> [Doc] --- Displaying @Doc@ values. +-- Displaying @Doc@ values. instance Show Doc where showsPrec _ doc cont = showDoc doc cont @@ -357,13 +373,13 @@ render :: Doc -> String -- | 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 +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 @@ -371,7 +387,7 @@ -- | A rendering style. data Style = Style { mode :: Mode -- ^ The rendering mode - , lineLength :: Int -- ^ Length of line, in chars + , lineLength :: Int -- ^ Length of line, in chars , ribbonsPerLine :: Float -- ^ Ratio of ribbon length to line length } @@ -380,10 +396,10 @@ 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 +data Mode = PageMode -- ^ Normal + | ZigZagMode -- ^ With zig-zag cuts + | LeftMode -- ^ No indentation, infinitely long lines + | OneLineMode -- ^ All on one line -- --------------------------------------------------------------------------- -- The Doc calculus @@ -411,11 +427,11 @@ ~~~~~~~~~~~~~ text s <> text t = text (s++t) text "" <> x = x, if x non-empty - + ** because of law n6, t2 only holds if x doesn't ** start with `nest'. - + Laws for nest ~~~~~~~~~~~~~ nest 0 x = x @@ -431,7 +447,7 @@ Miscellaneous ~~~~~~~~~~~~~ (text s <> x) $$ y = text s <> ((text "" <> x) $$ - nest (-length s) y) + nest (-length s) y) (x $$ y) <> z = x $$ (y <> z) if y non-empty @@ -448,12 +464,12 @@ 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 You might think that the following verion of would be neater: -<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ +<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ nest (-length s) y) But it doesn't work, for if x=empty, we would have @@ -528,14 +544,15 @@ data Doc = Empty -- empty | NilAbove Doc -- text "" $$ x - | TextBeside TextDetails !Int Doc -- text s <> x + | TextBeside TextDetails !Int Doc -- text s <> x | Nest !Int Doc -- nest k x | Union Doc Doc -- ul `union` ur | NoDoc -- The empty set of documents | Beside Doc Bool Doc -- True <=> space between | Above Doc Bool Doc -- True <=> never overlap -type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside +-- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside +type RDoc = Doc reduceDoc :: Doc -> RDoc @@ -544,34 +561,41 @@ reduceDoc p = p -data TextDetails = Chr Char - | Str String - | PStr String +-- | The TextDetails data type +-- +-- A TextDetails represents a fragment of text that will be +-- output at some point. +data TextDetails = Chr Char -- ^ A single Char fragment + | Str String -- ^ A whole String fragment + | PStr String -- ^ Used to represent a Fast String fragment + -- but now deprecated and identical to the + -- Str constructor. + space_text, nl_text :: TextDetails space_text = Chr ' ' nl_text = Chr '\n' {- Here are the invariants: - + 1) The argument of NilAbove is never Empty. Therefore a NilAbove occupies at least two lines. - + 2) The argument of @TextBeside@ is never @Nest@. - - - 3) The layouts of the two arguments of @Union@ both flatten to the same + + + 3) The layouts of the two arguments of @Union@ both flatten to the same string. - + 4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@. - - 5) A @NoDoc@ may only appear on the first line of the left argument of an + + 5) A @NoDoc@ may only appear on the first line of the left argument of an union. Therefore, the right argument of an union can never be equivalent to the empty set (@NoDoc@). - + 6) An empty document is always represented by @Empty@. It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s. - + 7) 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 @@ -595,10 +619,10 @@ -- Notice the difference between --- * NoDoc (no documents) --- * Empty (one empty document; no height and no width) --- * text "" (a document containing the empty string; --- one line high, but has no width) +-- * NoDoc (no documents) +-- * Empty (one empty document; no height and no width) +-- * text "" (a document containing the empty string; +-- one line high, but has no width) -- --------------------------------------------------------------------------- @@ -612,7 +636,8 @@ char c = textBeside_ (Chr c) 1 Empty text s = case length s of {sl -> textBeside_ (Str s) sl Empty} ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty} -zeroWidthText s = textBeside_ (Str s) 0 Empty +sizedText l s = textBeside_ (Str s) l Empty +zeroWidthText = sizedText 0 nest k p = mkNest k (reduceDoc p) -- Externally callable version @@ -651,13 +676,13 @@ aboveNest _ _ k _ | k `seq` False = undefined aboveNest NoDoc _ _ _ = 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 _ 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 = k1 `seq` textBeside_ s sl rest where @@ -670,16 +695,17 @@ nilAboveNest :: Bool -> Int -> RDoc -> RDoc --- Specification: text s <> nilaboveNest g k q +-- Specification: text s <> nilaboveNest g k q -- = text s <> (text "" $g$ nest k q) nilAboveNest _ k _ | k `seq` False = undefined -nilAboveNest _ _ 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 > 0) -- No newline if no overlap - = textBeside_ (Str (spaces k)) k q - | otherwise -- Put them really above +nilAboveNest g k q | not g && k > 0 -- No newline if no overlap + = textBeside_ (Str (indent k)) k q + | otherwise -- Put them really above = nilAbove_ (mkNest k q) -- --------------------------------------------------------------------------- @@ -695,14 +721,14 @@ beside :: Doc -> Bool -> RDoc -> RDoc -- Specification: beside g p q = p q - + beside NoDoc _ _ = NoDoc -beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q) +beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g 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 - [ && (op1 == <> || op1 == <+>) ] -} +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 beside p@(Above _ _ _) g q = beside (reduceDoc p) g q @@ -715,7 +741,7 @@ nilBeside :: Bool -> RDoc -> RDoc --- Specification: text "" <> nilBeside g p +-- Specification: text "" <> nilBeside g p -- = text "" p nilBeside _ Empty = Empty -- Hence the text "" in the spec @@ -747,12 +773,13 @@ sep1 _ NoDoc _ _ = NoDoc sep1 g (p `Union` q) k ys = sep1 g p k ys `union_` - (aboveNest q False k (reduceDoc (vcat ys))) + 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 - n) ys) -sep1 _ (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 _ (Above {}) _ _ = error "sep1 Above" sep1 _ (Beside {}) _ _ = error "sep1 Beside" @@ -763,10 +790,11 @@ sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc -sepNB g (Nest _ p) k ys = sepNB g p k ys -- Never triggered, because of invariant (2) +sepNB g (Nest _ p) k ys = sepNB g p k ys + -- Never triggered, because of invariant (2) sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest)) - `mkUnion` + `mkUnion` nilAboveNest True k (reduceDoc (vcat ys)) where rest | g = hsep ys @@ -787,7 +815,8 @@ -- fillIndent k [] = [] -- fillIndent k [p] = p -- fillIndent k (p1:p2:ps) = --- oneLiner p1 fillIndent (k + length p1 + g ? 1 : 0) (remove_nests (oneLiner p2) : ps) +-- oneLiner p1 fillIndent (k + length p1 + g ? 1 : 0) +-- (remove_nests (oneLiner p2) : ps) -- `Union` -- (p1 $*$ nest (-k) (fillIndent 0 ps)) -- @@ -805,7 +834,7 @@ fill1 _ NoDoc _ _ = NoDoc fill1 g (p `Union` q) k ys = fill1 g p k ys `union_` - (aboveNest q False k (fill g ys)) + 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 - n) ys) @@ -817,15 +846,18 @@ fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc fillNB _ _ k _ | k `seq` False = undefined -fillNB g (Nest _ p) k ys = fillNB g p k ys -- Never triggered, because of invariant (2) +fillNB g (Nest _ p) k ys = fillNB g p k ys + -- Never triggered, because of invariant (2) fillNB _ Empty _ [] = Empty fillNB g Empty k (Empty:ys) = fillNB g Empty k ys fillNB g Empty k (y:ys) = fillNBE g k y ys fillNB g p k ys = fill1 g p k ys fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc -fillNBE g k y ys = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k1 ys) - `mkUnion` +fillNBE g k y ys = nilBeside g + (fill1 g ((elideNest . oneLiner . reduceDoc) y) + k1 ys) + `mkUnion` nilAboveNest True k (fill g (y:ys)) where k1 | g = k - 1 @@ -882,7 +914,7 @@ 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 (p `Union` q) = nicest1 w r sl (get1 w sl p) (get1 w sl q) get1 _ _ (Above {}) = error "best get1 Above" get1 _ _ (Beside {}) = error "best get1 Beside" @@ -897,7 +929,7 @@ fits :: Int -- Space available -> Doc -> Bool -- True if *first line* of Doc fits in space available - + fits n _ | n < 0 = False fits _ NoDoc = False fits _ Empty = True @@ -949,9 +981,9 @@ = fullRender (mode the_style) (lineLength the_style) (ribbonsPerLine the_style) - string_txt - "" - doc + string_txt + "" + doc render doc = showDoc doc "" @@ -964,12 +996,14 @@ string_txt (PStr s1) s2 = s1 ++ s2 -fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc) -fullRender LeftMode _ _ txt end doc = easy_display nl_text txt end (reduceDoc doc) +fullRender OneLineMode _ _ txt end doc + = easy_display space_text txt end (reduceDoc doc) +fullRender LeftMode _ _ txt end doc + = easy_display nl_text txt end (reduceDoc doc) fullRender the_mode line_length ribbons_per_line txt end doc = display the_mode line_length ribbon_length txt end best_doc - where + where best_doc = best the_mode hacked_line_length ribbon_length (reduceDoc doc) hacked_line_length, ribbon_length :: Int @@ -990,31 +1024,31 @@ lay _ (Beside {}) = error "display lay Beside" lay _ NoDoc = error "display lay NoDoc" lay _ (Union {}) = error "display lay Union" - + lay k (NilAbove p) = nl_text `txt` lay k p - + lay k (TextBeside s sl p) = case the_mode of ZigZagMode | k >= gap_width -> nl_text `txt` ( - Str (multi_ch shift '/') `txt` ( - nl_text `txt` ( - lay1 (k - shift) s sl p))) + Str (replicate shift '/') `txt` ( + nl_text `txt` + lay1 (k - shift) s sl p )) | k < 0 -> nl_text `txt` ( - Str (multi_ch shift '\\') `txt` ( - nl_text `txt` ( - lay1 (k + shift) s sl p ))) + Str (replicate shift '\\') `txt` ( + nl_text `txt` + lay1 (k + shift) s sl p )) _ -> lay1 k s sl p - + lay1 k _ sl _ | k+sl `seq` False = undefined lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p) - + lay2 k _ | k `seq` False = undefined lay2 k (NilAbove p) = nl_text `txt` lay k p - lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p) + lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p lay2 k (Nest _ p) = lay2 k p lay2 _ Empty = end lay2 _ (Above {}) = error "display lay2 Above" @@ -1029,39 +1063,23 @@ cant_fail = error "easy_display: NoDoc" easy_display :: TextDetails -> (TextDetails -> a -> a) -> a -> Doc -> a -easy_display nl_space_text txt end doc +easy_display nl_space_text txt end doc = lay doc cant_fail where lay NoDoc no_doc = no_doc - lay (Union _p q) _ = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc + lay (Union _p q) _ = {- lay p -} lay q cant_fail + -- Second arg can't be NoDoc lay (Nest _ p) no_doc = lay p no_doc lay Empty _ = end - lay (NilAbove p) _ = nl_space_text `txt` lay p cant_fail -- NoDoc always on first line + lay (NilAbove p) _ = nl_space_text `txt` lay p cant_fail + -- NoDoc always on first line lay (TextBeside s _ p) no_doc = s `txt` lay p no_doc lay (Above {}) _ = error "easy_display Above" lay (Beside {}) _ = error "easy_display Beside" --- 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 +-- an old version inserted tabs being 8 columns apart in the output. indent :: Int -> String -indent n = spaces n - -multi_ch :: Int -> Char -> String -multi_ch 0 _ = "" -multi_ch n ch = ch : multi_ch (n - 1) ch - --- (spaces n) generates a list of n spaces --- --- returns the empty string on negative argument. --- -spaces :: Int -> String -spaces n - {- - | n < 0 = trace "Warning: negative indentation" "" - -} - | n <= 0 = "" - | otherwise = ' ' : spaces (n - 1) +indent n = replicate n ' ' {- Q: What is the reason for negative indentation (i.e. argument to indent diff --git a/pretty.cabal b/pretty.cabal --- a/pretty.cabal +++ b/pretty.cabal @@ -1,15 +1,23 @@ -name: pretty -version: 1.0.1.2 -license: BSD3 -license-file: LICENSE -maintainer: libraries@haskell.org -bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries/pretty -synopsis: Pretty-printing library -category: Text +name: pretty +version: 1.1.0.0 +synopsis: Pretty-printing library description: - This package contains John Hughes's pretty-printing library, - heavily modified by Simon Peyton Jones. -build-type: Simple + This package contains a pretty-printing library, a set of API's + that provides a way to easily print out text in a consistent + format of your choosing. This is useful for compilers and related + tools. + . + This library was originally designed by John Hughes's and has since + been heavily modified by Simon Peyton Jones. + +license: BSD3 +license-file: LICENSE +category: Text +maintainer: David Terei +homepage: http://github.com/haskell/pretty +bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries/pretty +stability: Stable +build-type: Simple Cabal-Version: >= 1.6 Library @@ -19,6 +27,6 @@ build-depends: base >= 3 && < 5 source-repository head - type: darcs - location: http://darcs.haskell.org/packages/pretty/ + type: git + location: http://github.com/haskell/pretty.git