diff --git a/Text/PrettyPrint/HughesPJ.hs b/Text/PrettyPrint/HughesPJ.hs --- a/Text/PrettyPrint/HughesPJ.hs +++ b/Text/PrettyPrint/HughesPJ.hs @@ -174,7 +174,7 @@ -- * Constructing documents -- ** Converting values into documents - char, text, ptext, + char, text, ptext, zeroWidthText, int, integer, float, double, rational, -- ** Simple derived documents @@ -260,6 +260,10 @@ -- | An obsolete function, now identical to 'text'. ptext :: 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)@ @@ -347,7 +351,7 @@ -- Displaying @Doc@ values. instance Show Doc where - showsPrec prec doc cont = showDoc doc cont + showsPrec _ doc cont = showDoc doc cont -- | Renders the document as a string using the default 'style'. render :: Doc -> String @@ -407,6 +411,10 @@ ~~~~~~~~~~~~~ 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 ~~~~~~~~~~~~~ @@ -422,8 +430,8 @@ Miscellaneous ~~~~~~~~~~~~~ - (text s <> x) $$ y = text s <> ((text "" <> x)) $$ - nest (-length s) y) + (text s <> x) $$ y = text s <> ((text "" <> x) $$ + nest (-length s) y) (x $$ y) <> z = x $$ (y <> z) if y non-empty @@ -483,18 +491,31 @@ brackets p = char '[' <> p <> char ']' braces p = char '{' <> p <> char '}' +-- lazy list versions +hcat = reduceAB . foldr (beside_' False) empty +hsep = reduceAB . foldr (beside_' True) empty +vcat = reduceAB . foldr (above_' True) empty -hcat = foldr (<>) empty -hsep = foldr (<+>) empty -vcat = foldr ($$) empty +beside_' :: Bool -> Doc -> Doc -> Doc +beside_' _ p Empty = p +beside_' g p q = Beside p g q +above_' :: Bool -> Doc -> Doc -> Doc +above_' _ p Empty = p +above_' g p q = Above p g q + +reduceAB :: Doc -> Doc +reduceAB (Above Empty _ q) = q +reduceAB (Beside Empty _ q) = q +reduceAB doc = doc + hang d1 n d2 = sep [d1, nest n d2] -punctuate p [] = [] +punctuate _ [] = [] punctuate p (d:ds) = go d ds where - go d [] = [d] - go d (e:es) = (d <> p) : go e es + go d' [] = [d'] + go d' (e:es) = (d' <> p) : go e es -- --------------------------------------------------------------------------- -- The Doc data type @@ -526,47 +547,50 @@ data TextDetails = Chr Char | Str String | PStr String +space_text, nl_text :: TextDetails 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. + 1) The argument of NilAbove is never Empty. Therefore + a NilAbove occupies at least two lines. - * The arugment of @TextBeside@ is never @Nest@. + 2) The argument of @TextBeside@ is never @Nest@. - * The layouts of the two arguments of @Union@ both flatten to the same - string. + 3) The layouts of the two arguments of @Union@ both flatten to the same + string. - * The arguments of @Union@ are either @TextBeside@, or @NilAbove@. + 4) 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. + 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@). - * An empty document is always represented by @Empty@. It can't be - hidden inside a @Nest@, or a @Union@ of two @Empty@s. + 6) 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. + 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 + (3), this invariant means that the right argument must have at + least two lines. -} - -- Arg of a NilAbove is always an RDoc +-- Invariant: Args to the 4 functions below are always RDocs +nilAbove_ :: RDoc -> RDoc nilAbove_ p = NilAbove p -- Arg of a TextBeside is always an RDoc +textBeside_ :: TextDetails -> Int -> RDoc -> RDoc textBeside_ s sl p = TextBeside s sl p - -- Arg of Nest is always an RDoc +nest_ :: Int -> RDoc -> RDoc nest_ k p = Nest k p - -- Args of union are always RDocs +union_ :: RDoc -> RDoc -> RDoc union_ p q = Union p q @@ -588,19 +612,22 @@ 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 nest k p = mkNest k (reduceDoc p) -- Externally callable version -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it +mkNest :: Int -> Doc -> Doc mkNest k _ | k `seq` False = undefined mkNest k (Nest k1 p) = mkNest (k + k1) p -mkNest k NoDoc = NoDoc -mkNest k Empty = Empty +mkNest _ NoDoc = NoDoc +mkNest _ Empty = Empty mkNest 0 p = 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 -- --------------------------------------------------------------------------- @@ -623,11 +650,11 @@ -- Specfication: aboveNest p g k q = p $g$ (nest k q) aboveNest _ _ k _ | k `seq` False = undefined -aboveNest NoDoc g k q = NoDoc +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 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 @@ -637,7 +664,9 @@ k1 = k - sl rest = case p of Empty -> nilAboveNest g k1 q - other -> aboveNest p g k1 q + _ -> aboveNest p g k1 q +aboveNest (Above {}) _ _ _ = error "aboveNest Above" +aboveNest (Beside {}) _ _ _ = error "aboveNest Beside" nilAboveNest :: Bool -> Int -> RDoc -> RDoc @@ -645,7 +674,7 @@ -- = text s <> (text "" $g$ nest k q) nilAboveNest _ k _ | k `seq` False = undefined -nilAboveNest g k 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 @@ -667,9 +696,9 @@ 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 @@ -682,14 +711,14 @@ where rest = case p of Empty -> nilBeside g q - other -> beside p g q + _ -> beside p g q nilBeside :: Bool -> RDoc -> RDoc -- 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 1 p | otherwise = p @@ -704,7 +733,8 @@ sep = sepX True -- Separate with spaces cat = sepX False -- Don't -sepX x [] = empty +sepX :: Bool -> [Doc] -> Doc +sepX _ [] = empty sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps @@ -713,8 +743,8 @@ -- `union` x $$ nest k (vcat ys) sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc -sep1 g _ k ys | k `seq` False = undefined -sep1 g NoDoc k ys = NoDoc +sep1 _ _ k _ | k `seq` False = undefined +sep1 _ NoDoc _ _ = NoDoc sep1 g (p `Union` q) k ys = sep1 g p k ys `union_` (aboveNest q False k (reduceDoc (vcat ys))) @@ -722,18 +752,22 @@ 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 g (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" -- 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 g (Nest _ p) k ys = sepNB g p k ys +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 Empty k ys = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion` - nilAboveNest False k (reduceDoc (vcat ys)) + nilAboveNest True k (reduceDoc (vcat ys)) where rest | g = hsep ys | otherwise = hcat ys @@ -746,21 +780,29 @@ fsep = fill True fcat = fill False --- Specification: --- fill [] = empty --- fill [p] = p --- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) --- (fill (oneLiner p2 : ps)) --- `union` --- p1 $$ fill ps +-- Specification: +-- +-- fill g docs = fillIndent 0 docs +-- +-- 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) +-- `Union` +-- (p1 $*$ nest (-k) (fillIndent 0 ps)) +-- +-- $*$ is defined for layouts (not Docs) as +-- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2 +-- | otherwise = layout1 $+$ layout2 -fill g [] = empty +fill :: Bool -> [Doc] -> RDoc +fill _ [] = empty fill g (p:ps) = fill1 g (reduceDoc p) 0 ps fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc -fill1 g _ k ys | k `seq` False = undefined -fill1 g NoDoc k ys = NoDoc +fill1 _ _ k _ | k `seq` False = undefined +fill1 _ NoDoc _ _ = NoDoc fill1 g (p `Union` q) k ys = fill1 g p k ys `union_` (aboveNest q False k (fill g ys)) @@ -770,19 +812,28 @@ 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 - sl) ys) +fill1 _ (Above {}) _ _ = error "fill1 Above" +fill1 _ (Beside {}) _ _ = error "fill1 Beside" -fillNB g _ k ys | k `seq` False = undefined -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) +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 _ 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` - nilAboveNest False k (fill g (y:ys)) + nilAboveNest True k (fill g (y:ys)) where k1 | g = k - 1 | otherwise = k -fillNB g p k ys = fill1 g p k ys - +elideNest :: Doc -> Doc +elideNest (Nest _ d) = d +elideNest d = d -- --------------------------------------------------------------------------- -- Selecting the best layout @@ -793,28 +844,32 @@ -> RDoc -> RDoc -- No unions in here! -best OneLineMode w r p - = get p +best OneLineMode _ _ p0 + = get p0 -- unused, due to the use of easy_display in full_render where get Empty = Empty get NoDoc = NoDoc get (NilAbove p) = nilAbove_ (get p) get (TextBeside s sl p) = textBeside_ s sl (get p) - get (Nest k p) = get p -- Elide nest + get (Nest _ p) = get p -- Elide nest get (p `Union` q) = first (get p) (get q) + get (Above {}) = error "best OneLineMode get Above" + get (Beside {}) = error "best OneLineMode get Beside" -best mode w r p - = get w p +best _ w0 r p0 + = get w0 p0 where get :: Int -- (Remaining) width of line -> Doc -> Doc get w _ | w==0 && False = undefined - 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 - k) p) get w (p `Union` q) = nicest w r (get w p) (get w q) + get _ (Above {}) = error "best get Above" + get _ (Beside {}) = error "best get Beside" get1 :: Int -- (Remaining) width of line -> Int -- Amount of first line already eaten up @@ -822,15 +877,20 @@ -> Doc -- No unions in here! get1 w _ _ | w==0 && False = undefined - get1 w sl Empty = Empty - get1 w sl NoDoc = NoDoc + 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 k p) = get1 w sl 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 _ _ (Above {}) = error "best get1 Above" + get1 _ _ (Beside {}) = error "best get1 Beside" +nicest :: Int -> Int -> Doc -> Doc -> Doc nicest w r p q = nicest1 w r 0 p q + +nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc nicest1 w r sl p q | fits ((w `minn` r) - sl) p = p | otherwise = q @@ -838,53 +898,67 @@ -> Doc -> Bool -- True if *first line* of Doc fits in space available -fits n p | n < 0 = False -fits n NoDoc = False -fits n Empty = True -fits n (NilAbove _) = True +fits n _ | n < 0 = False +fits _ NoDoc = False +fits _ Empty = True +fits _ (NilAbove _) = True fits n (TextBeside _ sl p) = fits (n - sl) p +fits _ (Above {}) = error "fits Above" +fits _ (Beside {}) = error "fits Beside" +fits _ (Union {}) = error "fits Union" +fits _ (Nest {}) = error "fits Nest" +minn :: Int -> Int -> Int minn x y | x < y = x | otherwise = y -- @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler. -- @first@ returns its first argument if it is non-empty, otherwise its second. -first p q | nonEmptySet p = p +first :: Doc -> Doc -> Doc +first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused | 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 (Above {}) = error "nonEmptySet Above" +nonEmptySet (Beside {}) = error "nonEmptySet Beside" -- @oneLiner@ returns the one-line members of the given set of @Doc@s. 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 (Above {}) = error "oneLiner Above" +oneLiner (Beside {}) = error "oneLiner Beside" -- --------------------------------------------------------------------------- -- Displaying the best layout -renderStyle style doc - = fullRender (mode style) - (lineLength style) - (ribbonsPerLine style) +renderStyle the_style doc + = fullRender (mode the_style) + (lineLength the_style) + (ribbonsPerLine the_style) string_txt "" doc render doc = showDoc doc "" + +showDoc :: Doc -> String -> String showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest 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 = s1 ++ s2 @@ -893,27 +967,34 @@ 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 mode line_length ribbons_per_line txt end doc - = display mode line_length ribbon_length txt end best_doc +fullRender the_mode line_length ribbons_per_line txt end doc + = display the_mode line_length ribbon_length txt end best_doc where - best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc) + best_doc = best the_mode 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 -> maxBound; other -> line_length } + hacked_line_length = case the_mode of + ZigZagMode -> maxBound + _ -> line_length -display mode page_width ribbon_width txt end doc +display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a +display the_mode page_width ribbon_width txt end doc = case page_width - ribbon_width of { gap_width -> case gap_width `quot` 2 of { shift -> let lay k _ | k `seq` False = undefined lay k (Nest k1 p) = lay (k + k1) p - lay k Empty = end + lay _ Empty = end + lay _ (Above {}) = error "display lay Above" + 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 mode of + = case the_mode of ZigZagMode | k >= gap_width -> nl_text `txt` ( Str (multi_ch shift '/') `txt` ( @@ -926,7 +1007,7 @@ nl_text `txt` ( lay1 (k + shift) s sl p ))) - other -> lay1 k 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) @@ -935,57 +1016,80 @@ 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 + lay2 _ Empty = end + lay2 _ (Above {}) = error "display lay2 Above" + lay2 _ (Beside {}) = error "display lay2 Beside" + lay2 _ NoDoc = error "display lay2 NoDoc" + lay2 _ (Union {}) = error "display lay2 Union" in lay 0 doc }} +cant_fail :: a cant_fail = error "easy_display: NoDoc" -easy_display nl_text txt end doc + +easy_display :: TextDetails -> (TextDetails -> a -> a) -> a -> Doc -> a +easy_display nl_space_text txt end doc = lay doc cant_fail where lay NoDoc no_doc = no_doc - lay (Union p q) no_doc = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc - lay (Nest k p) no_doc = lay p no_doc - lay Empty no_doc = end - 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 + 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 (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 +indent :: Int -> String indent n = spaces n -multi_ch 0 ch = "" +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 -- --- 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) +-- returns the empty string on negative argument. +-- +spaces :: Int -> String +spaces n + {- + | n < 0 = trace "Warning: negative indentation" "" + -} + | n <= 0 = "" + | otherwise = ' ' : spaces (n - 1) -{- Comments from Johannes Waldmann about what the problem might be: +{- +Q: What is the reason for negative indentation (i.e. argument to indent + is < 0) ? - 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 +A: +This indicates an error in the library client's code. +If we compose a <> b, and the first line of b is more indented than some +other lines of b, the law (<> eats nests) may cause the pretty +printer to produce an invalid layout: + +doc |0123345 +------------------ +d1 |a...| +d2 |...b| + |c...| + +d1<>d2 |ab..| + c|....| + +Consider a <> b, let `s' be the length of the last line of `a', `k' the +indentation of the first line of b, and `k0' the indentation of the +left-most line b_i of b. + +The produced layout will have negative indentation if `k - k0 > s', as +the first line of b will be put on the (s+1)th column, effectively +translating b horizontally by (k-s). Now if the i^th line of b has an +indentation k0 < (k-s), it is translated out-of-page, causing +`negative indentation'. -} + diff --git a/pretty.cabal b/pretty.cabal --- a/pretty.cabal +++ b/pretty.cabal @@ -1,11 +1,13 @@ name: pretty -version: 1.0.0.0 +version: 1.0.1.0 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org synopsis: Pretty-printing library +category: Text description: - This package contains a pretty-printing library. + This package contains John Hughes's pretty-printing library, + heavily modified by Simon Peyton Jones. build-type: Simple exposed-modules: Text.PrettyPrint