diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,3 +1,4 @@ +Portions Copyright 2013, Google, Inc. Copyright 2011, Edward Kmett Copyright 2000, Daan Leijen diff --git a/src/Text/PrettyPrint/Free.hs b/src/Text/PrettyPrint/Free.hs --- a/src/Text/PrettyPrint/Free.hs +++ b/src/Text/PrettyPrint/Free.hs @@ -2,15 +2,16 @@ ----------------------------------------------------------------------------- -- | -- Module : Text.PrettyPrint.Free --- Copyright : Edward Kmett (c) 2011, --- Daan Leijen (c) 2000 +-- Copyright : Google, Inc. (c) 2013, +-- Edward Kmett (c) 2011, +-- Daan Leijen (c) 2000 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : portable -- --- Pretty print module based on Daan Leijen's implementation of Philip Wadler's +-- Pretty print module based on Daan Leijen's implementation of Philip Wadler's -- \"prettier printer\" -- -- @ @@ -60,8 +61,8 @@ -- -- * A type argument has been added and embedded 'effects' can be seen in -- the SimpleDoc type. --- --- +-- +-- ----------------------------------------------------------- module Text.PrettyPrint.Free ( @@ -70,7 +71,7 @@ -- * Basic combinators , char, text, nest, line, linebreak, group, softline - , softbreak + , softbreak, hardline, flatAlt, flatten -- * Alignment -- @@ -106,7 +107,7 @@ , Pretty(..) -- * Rendering - , SimpleDoc(..), renderPretty, renderCompact + , SimpleDoc(..), renderPretty, renderCompact, renderSmart , displayS, displayIO -- * Undocumented diff --git a/src/Text/PrettyPrint/Free/Internal.hs b/src/Text/PrettyPrint/Free/Internal.hs --- a/src/Text/PrettyPrint/Free/Internal.hs +++ b/src/Text/PrettyPrint/Free/Internal.hs @@ -2,15 +2,17 @@ ----------------------------------------------------------------------------- -- | -- Module : Text.PrettyPrint.Free.Internal --- Copyright : Edward Kmett (c) 2011, --- Daan Leijen (c) 2000 +-- Copyright : Google, Inc. (c) 2013, +-- Edward Kmett (c) 2011, +-- Daan Leijen (c) 2000 +-- -- License : BSD-style (see the file LICENSE) -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : portable -- --- Pretty print module based on Daan Leijen's implementation of Philip Wadler's +-- Pretty print module based on Daan Leijen's implementation of Philip Wadler's -- \"prettier printer\" -- -- @ @@ -50,7 +52,7 @@ -- 'renderCompact' for compact output. The pretty printing algorithm -- also uses a ribbon-width now for even prettier output. -- --- * There are two display routines, 'displayS' for strings and 'displayIO' +-- * There are two display routines, 'displayS' for strings and 'displayIO' -- for file based output. -- -- * There is a 'Pretty' class. @@ -60,8 +62,8 @@ -- -- * A type argument has been added and embedded 'effects' can be seen in -- the SimpleDoc type. --- --- +-- +-- ----------------------------------------------------------- module Text.PrettyPrint.Free.Internal ( @@ -70,7 +72,7 @@ -- * Basic combinators , char, text, nest, line, linebreak, group, softline - , softbreak + , softbreak, hardline, flatAlt, flatten -- * Alignment -- @@ -106,7 +108,7 @@ , Pretty(..) -- * Rendering - , SimpleDoc(..), renderPretty, renderCompact + , SimpleDoc(..), renderPretty, renderCompact, renderSmart , displayS, displayIO -- * Undocumented @@ -159,7 +161,7 @@ -- encloses them in parenthesis. The documents are rendered -- horizontally if that fits the page. Otherwise they are aligned -- vertically. All comma separators are put in front of the elements. -tupled :: Foldable f => f (Doc e) -> Doc e +tupled :: Foldable f => f (Doc e) -> Doc e tupled = encloseSep lparen rparen comma (<+>) :: Doc e -> Doc e -> Doc e @@ -185,22 +187,26 @@ -- Which is layed out with a page width of 20 as: -- -- @ --- list [10,200,3000] +-- list [10, 200, 3000] -- @ -- -- But when the page width is 15, it is layed out as: -- -- @ --- list [10 --- ,200 --- ,3000] +-- list [ 10 +-- , 200 +-- , 3000 ] -- @ encloseSep :: Foldable f => Doc e -> Doc e -> Doc e -> f (Doc e) -> Doc e encloseSep left right sp ds0 = case toList ds0 of [] -> left <> right [d] -> left <> d <> right - ds -> align (cat (zipWith (<>) (left : repeat sp) ds) <> right) + ds -> group $ align $ left' + <> (vcat (zipWith (<>) (empty : repeat (sp <> space)) ds)) + <> right' + where left' = left <> flatAlt space empty + right' = flatAlt space empty <> right ----------------------------------------------------------- @@ -322,7 +328,7 @@ vcat = fold aboveBreak fold :: Foldable f => (Doc e -> Doc e -> Doc e) -> f (Doc e) -> Doc e -fold f xs = case toList xs of +fold f xs = case toList xs of [] -> empty _ -> foldr1 f xs @@ -465,7 +471,7 @@ -- | The document @space@ contains a single space, \" \". -- -- > x <+> y = x <> space <> y -space :: Doc e +space :: Doc e space = char ' ' -- | The document @dot@ contains a single dot, \".\". @@ -605,7 +611,7 @@ -- -- @ -- let empty :: Doc e --- nest :: Int -> Doc e -> Doc e +-- nest :: Int -> Doc e -> Doc e -- linebreak -- :: Doc e -- @ @@ -639,7 +645,7 @@ -- @ fill :: Int -> Doc e -> Doc e fill f d = width d $ \w -> - if (w >= f) + if (w >= f) then empty else text (spaces (f - w)) @@ -707,7 +713,7 @@ -- world -- @ align :: Doc e -> Doc e -align d = column $ \k -> +align d = column $ \k -> nesting $ \i -> nest (k - i) d --nesting might be negative :-) ----------------------------------------------------------- @@ -729,10 +735,12 @@ -- world -- @ data Doc e - = Empty + = Fail + | Empty | Char {-# UNPACK #-} !Char -- invariant: char is not '\n' | Text {-# UNPACK #-} !Int String -- invariant: text doesn't contain '\n' - | Line !(Maybe Char) -- Nothing <=> when undone by group, do not insert a space + | Line + | FlatAlt (Doc e) (Doc e) -- Render the first doc, but when flattened, render the second. | Cat (Doc e) (Doc e) | Nest {-# UNPACK #-} !Int (Doc e) | Union (Doc e) (Doc e) -- invariant: first lines of first doc longer than the first lines of the second doc @@ -745,7 +753,7 @@ instance Functor Doc where fmap _ Empty = Empty fmap _ (Char c) = Char c - fmap _ (Line b) = Line b + fmap _ Line = Line fmap _ (Text i s) = Text i s fmap f (Cat l r) = Cat (fmap f l) (fmap f r) fmap f (Nest i d) = Nest i (fmap f d) @@ -771,7 +779,7 @@ Empty >>= _ = Empty Char c >>= _ = Char c Text i s >>= _ = Text i s - Line b >>= _ = Line b + Line >>= _ = Line Cat l r >>= k = Cat (l >>= k) (r >>= k) Nest i d >>= k = Nest i (d >>= k) Union l r >>= k = Union (l >>= k) (r >>= k) @@ -796,9 +804,9 @@ empty = Empty instance MonadPlus Doc where - mplus = (<>) + mplus = (<>) mzero = empty - + -- | The data type @SimpleDoc@ represents rendered documents and is -- used by the display functions. -- @@ -807,8 +815,9 @@ -- provides two default display functions 'displayS' and -- 'displayIO'. You can provide your own display function by writing a -- function from a @SimpleDoc@ to your own output format. -data SimpleDoc e - = SEmpty +data SimpleDoc e + = SFail + | SEmpty | SChar {-# UNPACK #-} !Char (SimpleDoc e) | SText {-# UNPACK #-} !Int String (SimpleDoc e) | SLine {-# UNPACK #-} !Int (SimpleDoc e) @@ -854,14 +863,19 @@ -- current nesting level. Document @line@ behaves like @(text \" \")@ -- if the line break is undone by 'group'. line :: Doc e -line = Line (Just ' ') +line = FlatAlt Line space -- | The @linebreak@ document advances to the next line and indents to -- the current nesting level. Document @linebreak@ behaves like -- 'empty' if the line break is undone by 'group'. linebreak :: Doc e -linebreak = Line Nothing +linebreak = FlatAlt Line empty +-- | A linebreak that can not be flattened; it is guaranteed to be +-- rendered as a newline. +hardline :: Doc e +hardline = Line + -- | The document @(nest i x)@ renders document @x@ with the current -- indentation level increased by i (See also 'hang', 'align' and -- 'indent'). @@ -896,10 +910,17 @@ group :: Doc e -> Doc e group x = Union (flatten x) x +-- | @flatAlt@ creates a document that changes when flattened; normally +-- it is rendered as the first argument, but when flattened is rendered +-- as the second. +flatAlt :: Doc e -> Doc e -> Doc e +flatAlt = FlatAlt + flatten :: Doc e -> Doc e +flatten (FlatAlt _ y) = y flatten (Cat x y) = Cat (flatten x) (flatten y) flatten (Nest i x) = Nest i (flatten x) -flatten (Line brk) = maybe Empty Char brk +flatten Line = Fail flatten (Union x _) = flatten x flatten (Column f) = Column (flatten . f) flatten (Nesting f) = Nesting (flatten . f) @@ -929,7 +950,62 @@ -- @ribbonfrac@ should be between @0.0@ and @1.0@. If it is lower or -- higher, the ribbon width will be 0 or @width@ respectively. renderPretty :: Float -> Int -> Doc e -> SimpleDoc e -renderPretty rfrac w x +renderPretty = renderFits nicest1 + +-- | A slightly smarter rendering algorithm with more lookahead. It provides +-- provide earlier breaking on deeply nested structures. +-- For example, consider this python-ish pseudocode: +-- @fun(fun(fun(fun(fun([abcdefg, abcdefg])))))@ +-- If we put a softbreak (+ nesting 2) after each open parenthesis, and align +-- the elements of the list to match the opening brackets, this will render with +-- @renderPretty@ and a page width of 20c as: +-- @ +-- fun(fun(fun(fun(fun([ +-- | abcdef, +-- | abcdef, +-- ] +-- ))))) | +-- @ +-- Where the 20c. boundary has been marked with |. Because @renderPretty@ only +-- uses one-line lookahead, it sees that the first line fits, and is stuck +-- putting the second and third lines after the 20c mark. In contrast, +-- @renderSmart@ will continue to check the potential document up to the end of +-- the indentation level. Thus, it will format the document as: +-- +-- @ +-- fun( | +-- fun( | +-- fun( | +-- fun( | +-- fun([ | +-- abcdef, +-- abcdef, +-- ] | +-- ))))) | +-- @ +-- Which fits within the 20c. mark. +-- In addition, @renderSmart@ uses this lookahead to minimize the number of +-- lines printed, leading to more compact and visually appealing output. +-- Consider this example using the same syntax as above: +-- @aaaaaaaaaaa([abc, def, ghi])@ +-- When rendered with @renderPretty@ and a page width of 20c, we get: +-- @ +-- aaaaaaaaaaa([ abc +-- , def +-- , ghi ]) +-- @ +-- Whereas when rendered with @renderSmart@ and a page width of 20c, we get: +-- @ +-- aaaaaaaaaaa( +-- [abc, def, ghi]) +-- @ +renderSmart :: Int -> Doc e -> SimpleDoc e +renderSmart = renderFits nicestR 1.0 + +renderFits :: (Int -> Int -> Int -> Int -> SimpleDoc e -> SimpleDoc e + -> SimpleDoc e) + -> Float -> Int -> Doc e -> SimpleDoc e +renderFits nicest rfrac w x = best 0 0 (Cons 0 x Nil) where -- r :: the ribbon width in characters @@ -941,38 +1017,61 @@ best _ _ Nil = SEmpty best n k (Cons i d ds) = case d of + Fail -> SFail Empty -> best n k ds Char c -> let k' = k+1 in seq k' (SChar c (best n k' ds)) Text l s -> let k' = k+l in seq k' (SText l s (best n k' ds)) - Line _ -> SLine i (best i i ds) - Cat x' y -> best n k (Cons i x' (Cons i y ds)) - Nest j x' -> let i' = i+j in seq i' (best n k (Cons i' x' ds)) + Line -> SLine i (best i i ds) + FlatAlt l _ -> best n k (Cons i l ds) + Cat x' y -> best n k (Cons i x' (Cons i y ds)) + Nest j x' -> let i' = i+j in seq i' (best n k (Cons i' x' ds)) Effect e -> SEffect e (best n k ds) - Union x' y -> nicest n k (best n k (Cons i x' ds)) - (best n k (Cons i y ds)) - + Union p q -> nicest n k w r (best n k (Cons i p ds)) + (best n k (Cons i q ds)) Column f -> best n k (Cons i (f k) ds) Nesting f -> best n k (Cons i (f i) ds) Columns f -> best n k (Cons i (f w) ds) Ribbon f -> best n k (Cons i (f r) ds) - --nicest :: r = ribbon width, w = page width, - -- n = indentation of current line, k = current column - -- x and y, the (simple) documents to chose from. - -- precondition: first line of x are longer than the first line of y. - nicest n k x' y | fits wid x' = x' - | otherwise = y - where - wid = min (w - k) (r - k + n) - +-- @nicest1@ compares the first lines of the two documents. +-- n = nesting, k = column, p = pagewidth +nicest1 :: Int -> Int -> Int -> Int -> SimpleDoc e -> SimpleDoc e -> SimpleDoc e +nicest1 n k p r x' y | fits (min n k) wid x' = x' + | otherwise = y + where wid = min (p - k) (r - k + n) + fits _ w _ | w < 0 = False + fits _ _ SFail = False + fits _ _ SEmpty = True + fits m w (SChar _ x) = fits m (w - 1) x + fits m w (SText l _ x) = fits m (w - l) x + fits _ _ (SLine _ _) = True -fits :: Int -> SimpleDoc e -> Bool -fits w _ | w < 0 = False -fits _ SEmpty = True -fits w (SChar _ x) = fits (w - 1) x -fits w (SText l _ x) = fits (w - l) x -fits _ (SLine _ _) = True -fits w (SEffect _ x) = fits w x +-- @nicestR@ compares the initial lines of the two documents that are nested at +-- least as deep as the current nesting level. If the initial lines of both +-- documents fit within the page width, the document that takes fewer lines is +-- prefered, with preference toward the first. +nicestR :: Int -> Int -> Int -> Int -> SimpleDoc e -> SimpleDoc e -> SimpleDoc e +nicestR n k p r x' y = + if fits (min n k) wid x' <= fits (min n k) wid y then x' else y + where wid = min (p - k) (r - k + n) + inf = 1.0/0 :: Double + -- @fitsR@ has a little more lookahead: assuming that nesting roughly + -- corresponds to syntactic depth, @fitsR@ checks that not only the + -- current line fits, but the entire syntactic structure being formatted + -- at this level of indentation fits. If we were to remove the second + -- case for @SLine@, we would check that not only the current structure + -- fits, but also the rest of the document, which would be slightly more + -- intelligent but would have exponential runtime (and is prohibitively + -- expensive in practice). + -- m = minimum nesting level to fit in + -- w = the width in which to fit the first line + fits _ w _ | w < 0 = inf + fits _ _ SFail = inf + fits _ _ SEmpty = 0 + fits m w (SChar _ x) = fits m (w - 1) x + fits m w (SText l _ x) = fits m (w - l) x + fits m _ (SLine i x) | m < i = 1 + fits m (p - i) x + | otherwise = 0 ----------------------------------------------------------- @@ -992,11 +1091,12 @@ where scan _ [] = SEmpty scan k (d:ds) = case d of + Fail -> SFail Empty -> scan k ds Char c -> let k' = k+1 in seq k' (SChar c (scan k' ds)) Text l s -> let k' = k+l in seq k' (SText l s (scan k' ds)) Effect e -> SEffect e (scan k ds) - Line _ -> SLine 0 (scan 0 ds) + Line -> SLine 0 (scan 0 ds) Cat y z -> scan k (y:z:ds) Nest _ y -> scan k (y:ds) Union _ y -> scan k (y:ds) @@ -1017,6 +1117,8 @@ -- > showWidth :: Int -> Doc -> String -- > showWidth w x = displayS (renderPretty 0.4 w x) "" displayS :: SimpleDoc e -> ShowS +displayS SFail = error $ "@SFail@ can not appear uncaught in a " ++ + "rendered @SimpleDoc@" displayS SEmpty = id displayS (SChar c x) = showChar c . displayS x displayS (SText _ s x) = showString s . displayS x @@ -1029,6 +1131,8 @@ -- > hPutDoc handle doc = displayIO handle (renderPretty 0.4 100 doc) displayIO :: Handle -> SimpleDoc e -> IO () displayIO handle = go where + go SFail = error $ "@SFail@ can not appear uncaught in a " ++ + "rendered @SimpleDoc@" go SEmpty = return () go (SChar c x) = hPutChar handle c >> go x go (SText _ s x) = hPutStr handle s >> go x diff --git a/test/WLPPrintTests.hs b/test/WLPPrintTests.hs new file mode 100644 --- /dev/null +++ b/test/WLPPrintTests.hs @@ -0,0 +1,264 @@ +module Main where + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +import Text.PrettyPrint.Free.Internal + +main :: IO () +main = defaultMain [ + testGroup "Tests for each data constructor" conTests + , testGroup "Tests for some combinators" codeTests + , testGroup "Tests for the formatting algorithms" formatTests + , testGroup "Tests for the code examples in the documentation" docTests + ] + +conTests :: [Test] +conTests = [ + testCase "Empty tests" emptyTests + , testCase "Char tests" charTests + , testCase "Text tests" textTests + , testCase "Line tests" textTests + , testCase "FlatAlt tests" flatAltTests + , testCase "Cat tests" catTests + , testCase "Nest tests" nestTests + , testCase "Union tests" unionTests + , testCase "Column tests" columnTests + , testCase "Nesting tests" nestingTests + , testCase "Columns tests" columnsTests + , testCase "Ribbon tests" ribbonTests + ] + +------------------------------------------------------------ +-- We test the @Doc@ constructors. + +assertPretty :: Int -> String -> String -> Doc e -> Assertion +assertPretty w desc str doc = assertEqual (desc ++ " (pretty)") str + $ displayS (renderPretty 1.0 w doc) "" + +assertSmart :: Int -> String -> String -> Doc e -> Assertion +assertSmart w desc str doc = assertEqual (desc ++ " (smart)") str + $ displayS (renderSmart w doc) "" + +assertRender :: Int -> String -> String -> Doc e -> Assertion +assertRender w desc str doc = do assertPretty w desc str doc + assertSmart w desc str doc + +emptyTests :: Assertion +emptyTests = assertRender 80 "Empty test 1" "" empty + +charTests :: Assertion +charTests = assertRender 80 "Char test 1" "a" (char 'a') + +textTests :: Assertion +textTests = assertRender 80 "Text test 1" "text..." (text "text...") + +lineTests :: Assertion +lineTests = assertRender 80 "Line test 1" "\n" hardline + +flatAltTests :: Assertion +flatAltTests = do assertRender 80 "FlatAlt test 1" "x" + $ flatAlt (text "x") (text "y") + assertRender 80 "FlatAlt test 2" "y" + $ flatten $ flatAlt (text "x") (text "y") + +catTests :: Assertion +catTests = do assertRender 80 "Cat test 1" "some code" + $ text "some" <> space <> text "code" + +nestTests :: Assertion +nestTests = do assertRender 80 "Nest test 1" "foo bar" + $ text "foo" <+> nest 2 (text "bar") + assertRender 80 "Nest test 2" "foo\n bar" + $ text "foo" <> nest 2 (line <> text "bar") + +unionTests :: Assertion +unionTests = do assertRender 80 "Union test 1" "foo bar" + $ text "foo" text "bar" + assertRender 5 "Union test 2" "foo\nbar" + $ text "foo" text "bar" + +columnTests :: Assertion +columnTests = do assertRender 80 "Column test 1" "foo 4" + $ text "foo" <+> (column $ \c -> pretty c) + +nestingTests :: Assertion +nestingTests = do assertRender 80 "Nesting test 1" "foo 2" + $ text "foo" <+> (nest 2 $ nesting $ \n -> pretty n) + +columnsTests :: Assertion +columnsTests = do assertRender 21 "Columns test 1" "foo 21" + $ text "foo" <+> (nest 2 $ columns $ \w -> pretty w) + +ribbonTests :: Assertion +ribbonTests = do assertEqual "Ribbon test 1" "foo 32" + $ show (text "foo" <+> (ribbon $ \r -> pretty r)) + +------------------------------------------------------------ +-- We test some combinators. + +codeTests :: [Test] +codeTests = [ + testCase "@list@ tests" listTests + , testCase "@tupled@ tests" tupledTests + ] + +listTests :: Assertion +listTests = do assertRender 80 "@list@ test 1" "[1, 2, 3]" + $ pretty ([1, 2, 3] :: [Int]) + assertRender 5 "@list@ test 2" "[ 1\n, 2\n, 3 ]" + $ pretty ([1, 2, 3] :: [Int]) + +tupledTests :: Assertion +tupledTests = do assertRender 80 "@tupled@ test 1" "(1, True, a)" + $ pretty (1 :: Int, True, 'a') + assertRender 5 "@tupled@ test 2" "( 1\n, True\n, a )" + $ pretty (1 :: Int, True, 'a') + +------------------------------------------------------------ +-- We test some corner cases of the formatting algorithms on a prototypical +-- syntax for a scripting language (e.g. Python). + +formatTests :: [Test] +formatTests = [ + testCase "@renderPretty@ test" renderPrettyTest + , testCase "@renderSmart@ test" renderSmartTest + ] + +data Syn = Call String [Syn] -- name(syn, ..., syn) + | Plus Syn Syn -- syn + syn + | List [Syn] -- [syn, ..., syn] + | Name String + +instance Pretty Syn where + pretty (Call n s) = + text (n ++ "(") <> nest 2 (softbreak <> align body) rparen + where body = hcat $ punctuate (comma <> softline) (map pretty s) + pretty (Plus s t) = nest 2 (pretty s) text "+" nest 2 (pretty t) + pretty (List l) = list (map pretty l) + pretty (Name n) = text n + +deep :: Int -> Syn +deep 0 = List (map Name ["abc", "abcdef", "abcdef"]) +deep i = Call "fun" [deep (i - 1)] + +branch :: Int -> Syn +branch 0 = List (map Name ["abc", "abc"]) +branch i | i < 3 = Call "fun" [branch (i - 1), branch (i - 1)] + | otherwise = Call "fun" [branch (i - 1)] + +wide :: Syn +wide = Call "aaaaaaaaaaa" [List $ map Name ["abc", "def", "ghi"]] + +-- @renderPretty@ has only one line of lookahead, so it can not fit the +-- entire document within the pagewidth (20c), only the first line. +renderPrettyTest :: Assertion +renderPrettyTest = do assertPretty 20 "@renderPretty@ test 1" (concat [ + "fun(fun(fun(fun(fun(\n" + , " [ abc\n" + , " , abcdef\n" + , " , abcdef ]\n" + , " ))))\n" + , ")" ]) + $ pretty (deep 5) + assertPretty 20 "@renderPretty@ test 2" (concat [ + "fun(fun(fun([ abc\n" + , " , abc ],\n" + , " [ abc\n" + , " , abc ]\n" + , " ), fun([ abc\n" + , " , abc ],\n" + , " [ abc\n" + , " , abc ]\n" + , " )))" ]) + $ pretty (branch 3) + assertPretty 20 "@renderPretty@ test 3" (concat [ + "aaaaaaaaaaa([ abc\n" + , " , def\n" + , " , ghi ])" ]) + $ pretty wide + +-- @renderSmart@ has more sophisiticated lookahead, so it fits the entire +-- structure within the pagewidth (20c). +renderSmartTest :: Assertion +renderSmartTest = do assertSmart 20 "@renderSmart@ test 1" (concat [ + "fun(\n" + , " fun(\n" + , " fun(\n" + , " fun(\n" + , " fun(\n" + , " [ abc\n" + , " , abcdef\n" + , " , abcdef ]\n" + , " )))))" ]) + $ pretty (deep 5) + assertSmart 20 "@renderSmart@ test 2" (concat [ + "fun(\n" + , " fun(\n" + , " fun(\n" + , " fun(\n" + , " fun([ abc\n" + , " , abc ],\n" + , " [ abc\n" + , " , abc ]\n" + , " ),\n" + , " fun([ abc\n" + , " , abc ],\n" + , " [ abc\n" + , " , abc ])\n" + , " ))))" ]) + $ pretty (branch 5) + assertSmart 20 "@renderSmart@ test 3" (concat [ + "aaaaaaaaaaa(\n" + , " [abc, def, ghi])" ]) + $ pretty wide + +------------------------------------------------------------ +-- We test the code examples in the haddock comments. + +docTests :: [Test] +docTests = [ + testCase "@fill@ test" fillTest + , testCase "@fillBreak@ test" fillBreakTest + , testCase "@hang@ test" hangTest + , testCase "@align@ test" alignTest + ] + +types :: [(String, String)] +types = [ ("empty","Doc e") + , ("nest","Int -> Doc e -> Doc e") + , ("linebreak","Doc e") ] + +fillTest :: Assertion +fillTest = do assertRender 80 "@fill@ test 1" (concat [ + "let empty :: Doc e\n" + , " nest :: Int -> Doc e -> Doc e\n" + , " linebreak :: Doc e" ]) + $ text "let" <+> align (vcat (map ptype types)) + where ptype (name, tp) = + fill 6 (text name) <+> text "::" <+> text tp + +fillBreakTest :: Assertion +fillBreakTest = do assertRender 80 "@fillBreak@ test 1" (concat [ + "let empty :: Doc e\n" + , " nest :: Int -> Doc e -> Doc e\n" + , " linebreak\n" + , " :: Doc e" ]) + $ text "let" <+> align (vcat (map ptype types)) + where ptype (name, tp) = + fillBreak 6 (text name) <+> (text "::" <+> text tp) + +hangTest :: Assertion +hangTest = do assertRender 20 "@hang@ test 1" (concat [ + "the hang combinator\n" + , " indents these\n" + , " words !" ]) + $ hang 4 $ fillSep $ map text + $ words "the hang combinator indents these words !" + +alignTest :: Assertion +alignTest = do assertRender 20 "@align@ test 1" (concat [ + "hi nice\n" + , " world" ]) + $ text "hi" <+> (text "nice" $$ text "world") + where x $$ y = align $ x <> linebreak <> y diff --git a/wl-pprint-extras.cabal b/wl-pprint-extras.cabal --- a/wl-pprint-extras.cabal +++ b/wl-pprint-extras.cabal @@ -1,7 +1,7 @@ name: wl-pprint-extras category: Control, Monads, Text -version: 3.4 -cabal-version: >= 1.6 +version: 3.5 +cabal-version: >= 1.8 license: BSD3 license-file: LICENSE author: Edward A. Kmett @@ -25,11 +25,11 @@ build-depends: base == 4.*, containers >= 0.4 && < 0.6, - nats >= 0.1, - semigroups >= 0.9, - semigroupoids >= 3, + nats >= 0.1 && < 1, + semigroups >= 0.9 && < 1, + semigroupoids >= 3 && < 5, utf8-string >= 0.3.6 && < 0.4, - text == 0.11.* + text >= 0.11 && < 1.2 exposed-modules: Text.PrettyPrint.Free @@ -37,3 +37,17 @@ ghc-options: -Wall hs-source-dirs: src + +test-suite wl-pprint-tests + + build-depends: + base == 4.*, + wl-pprint-extras, + HUnit, + test-framework, + test-framework-hunit + + main-is: WLPPrintTests.hs + type: exitcode-stdio-1.0 + ghc-options: -Wall + hs-source-dirs: test