diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,19 @@ +# 1.6.0 + +## Breaking changes + +- Fix `fuse`'s handling of annotated documents: + - Don't remove annotations on empty documents. + - Apply fusion within annotations. +- Fix layouting of hard linebreaks with `Unbounded` page widths. + +## Non-breaking changes + +- Speed up `group` for documents containing linebreaks and previously + `group`ed documents. +- Add debugging helpers in `Data.Text.Prettyprint.Doc.Internal.Debug` +- Documentation improvements and fixes + # 1.5.1 - Removing trailing whitespace sometimes restored necessary whitespace in the diff --git a/bench/FasterUnsafeText.hs b/bench/FasterUnsafeText.hs --- a/bench/FasterUnsafeText.hs +++ b/bench/FasterUnsafeText.hs @@ -4,7 +4,7 @@ -import Criterion.Main +import Gauge.Main import Data.Char import Data.Text (Text) import qualified Data.Text as T diff --git a/bench/Fusion.hs b/bench/Fusion.hs --- a/bench/Fusion.hs +++ b/bench/Fusion.hs @@ -9,7 +9,7 @@ import Control.Monad import Control.Monad.State -import Criterion.Main +import Gauge.Main import Data.Text (Text) import qualified Data.Text as T import System.Random @@ -31,9 +31,9 @@ ] benchOptimize :: Benchmark -benchOptimize = env randomShortWords benchmark +benchOptimize = env randomShortWords benchmark_ where - benchmark = \shortWords -> + benchmark_ = \shortWords -> let doc = hsep (map pretty shortWords) in bgroup "Many small words" [ bench "Unoptimized" (nf renderLazy (layoutPretty defaultLayoutOptions doc)) diff --git a/bench/LargeOutput.hs b/bench/LargeOutput.hs --- a/bench/LargeOutput.hs +++ b/bench/LargeOutput.hs @@ -10,8 +10,7 @@ import Control.DeepSeq import Control.Monad.Compat -import Criterion -import Criterion.Main +import Gauge import Data.Char import Data.Map (Map) import qualified Data.Map as M diff --git a/prettyprinter.cabal b/prettyprinter.cabal --- a/prettyprinter.cabal +++ b/prettyprinter.cabal @@ -1,5 +1,5 @@ name: prettyprinter -version: 1.5.1 +version: 1.6.0 cabal-version: >= 1.10 category: User Interfaces, Text synopsis: A modern, easy to use, well-documented, extensible pretty-printer. @@ -27,6 +27,7 @@ exposed-modules: Data.Text.Prettyprint.Doc , Data.Text.Prettyprint.Doc.Internal + , Data.Text.Prettyprint.Doc.Internal.Debug , Data.Text.Prettyprint.Doc.Internal.Type , Data.Text.Prettyprint.Doc.Render.String , Data.Text.Prettyprint.Doc.Render.Text @@ -123,6 +124,7 @@ , pgp-wordlist >= 0.1 , bytestring >= 0.10 + , quickcheck-instances >= 0.3 , tasty >= 0.10 , tasty-hunit >= 0.9 , tasty-quickcheck >= 0.8 @@ -143,7 +145,7 @@ base >= 4.5 && < 5 , prettyprinter - , criterion >= 1.1 + , gauge >= 0.2 , mtl >= 2.1 , random >= 1.0 , text @@ -158,7 +160,7 @@ base >= 4.5 && < 5 , prettyprinter - , criterion >= 1.1 + , gauge >= 0.2 , text hs-source-dirs: bench @@ -171,11 +173,11 @@ benchmark large-output build-depends: base >= 4.5 && < 5 - , base-compat >=0.9.3 && <0.11 + , base-compat >=0.9.3 && <0.12 , prettyprinter , ansi-wl-pprint - , criterion >= 1.1 + , gauge >= 0.2 , QuickCheck >= 2.7 , containers , text diff --git a/src/Data/Text/Prettyprint/Doc.hs b/src/Data/Text/Prettyprint/Doc.hs --- a/src/Data/Text/Prettyprint/Doc.hs +++ b/src/Data/Text/Prettyprint/Doc.hs @@ -72,6 +72,9 @@ -- Speaking of alignment, had we not used 'align', the @->@ would be at the -- beginning of each line, and not beneath the @::@. -- +-- The 'Data.Text.Prettyprint.Doc.Util.putDocW' renderer used here is from +-- "Data.Text.Prettyprint.Doc.Util". +-- -- = General workflow -- -- @ diff --git a/src/Data/Text/Prettyprint/Doc/Internal.hs b/src/Data/Text/Prettyprint/Doc/Internal.hs --- a/src/Data/Text/Prettyprint/Doc/Internal.hs +++ b/src/Data/Text/Prettyprint/Doc/Internal.hs @@ -15,9 +15,7 @@ -- For a stable API, use the non-internal modules. For the special case of -- writing adaptors to this library’s @'Doc'@ type, see -- "Data.Text.Prettyprint.Doc.Internal.Type". -module Data.Text.Prettyprint.Doc.Internal ( - module Data.Text.Prettyprint.Doc.Internal -) where +module Data.Text.Prettyprint.Doc.Internal where @@ -526,8 +524,9 @@ group :: Doc ann -> Doc ann -- See note [Group: special flattening] group x = case changesUponFlattening x of - Nothing -> x - Just x' -> Union x' x + Flattened x' -> Union x' x + AlreadyFlat -> x + NeverFlat -> x -- Note [Group: special flattening] -- @@ -542,35 +541,52 @@ -- See https://github.com/quchen/prettyprinter/issues/22 for the corresponding -- ticket. +data FlattenResult a + = Flattened a + -- ^ @a@ is likely flatter than the input. + | AlreadyFlat + -- ^ The input was already flat, e.g. a 'Text'. + | NeverFlat + -- ^ The input couldn't be flattened: It contained a 'Line' or 'Fail'. + +instance Functor FlattenResult where + fmap f (Flattened a) = Flattened (f a) + fmap _ AlreadyFlat = AlreadyFlat + fmap _ NeverFlat = NeverFlat + -- | Choose the first element of each @Union@, and discard the first field of -- all @FlatAlt@s. -- --- The result is 'Just' if the element might change depending on the layout --- algorithm (i.e. contains differently renderable sub-documents), and 'Nothing' --- if the document is static (e.g. contains only a plain 'Empty' node). See --- [Group: special flattening] for further explanations. -changesUponFlattening :: Doc ann -> Maybe (Doc ann) +-- The result is 'Flattened' if the element might change depending on the layout +-- algorithm (i.e. contains differently renderable sub-documents), and 'AlreadyFlat' +-- if the document is static (e.g. contains only a plain 'Empty' node). +-- 'NeverFlat' is returned when the document cannot be flattened because it +-- contains a hard 'Line' or 'Fail'. +-- See [Group: special flattening] for further explanations. +changesUponFlattening :: Doc ann -> FlattenResult (Doc ann) changesUponFlattening = \doc -> case doc of - FlatAlt _ y -> Just (flatten y) - Line -> Just Fail - Union x _ -> changesUponFlattening x <|> Just x + FlatAlt _ y -> Flattened (flatten y) + Line -> NeverFlat + Union x _ -> Flattened x Nest i x -> fmap (Nest i) (changesUponFlattening x) Annotated ann x -> fmap (Annotated ann) (changesUponFlattening x) - Column f -> Just (Column (flatten . f)) - Nesting f -> Just (Nesting (flatten . f)) - WithPageWidth f -> Just (WithPageWidth (flatten . f)) + Column f -> Flattened (Column (flatten . f)) + Nesting f -> Flattened (Nesting (flatten . f)) + WithPageWidth f -> Flattened (WithPageWidth (flatten . f)) Cat x y -> case (changesUponFlattening x, changesUponFlattening y) of - (Nothing, Nothing) -> Nothing - (Just x', Nothing) -> Just (Cat x' y ) - (Nothing, Just y') -> Just (Cat x y') - (Just x', Just y') -> Just (Cat x' y') + (NeverFlat , _ ) -> NeverFlat + (_ , NeverFlat ) -> NeverFlat + (Flattened x' , Flattened y') -> Flattened (Cat x' y') + (Flattened x' , AlreadyFlat ) -> Flattened (Cat x' y) + (AlreadyFlat , Flattened y') -> Flattened (Cat x y') + (AlreadyFlat , AlreadyFlat ) -> AlreadyFlat - Empty -> Nothing - Char{} -> Nothing - Text{} -> Nothing - Fail -> Nothing + Empty -> AlreadyFlat + Char{} -> AlreadyFlat + Text{} -> AlreadyFlat + Fail -> NeverFlat where -- Flatten, but don’t report whether anything changes. flatten :: Doc ann -> Doc ann @@ -1401,7 +1417,7 @@ Nest 0 x -> go x Nest i x -> Nest i (go x) - Annotated _ Empty -> Empty + Annotated ann x -> Annotated ann (go x) FlatAlt x1 x2 -> FlatAlt (go x1) (go x2) Union x1 x2 -> Union (go x1) (go x2) @@ -1587,11 +1603,11 @@ -- -- - page width -- - minimum nesting level to fit in --- - width in which to fit the first line; Nothing is unbounded +-- - width in which to fit the first line newtype FittingPredicate ann = FittingPredicate (PageWidth -> Int - -> Maybe Int + -> Int -> SimpleDocStream ann -> Bool) deriving Typeable @@ -1624,6 +1640,9 @@ deriving (Eq, Ord, Show, Typeable) +defaultPageWidth :: PageWidth +defaultPageWidth = AvailablePerLine 80 1 + -- $ Test to avoid surprising behaviour -- >>> Unbounded > AvailablePerLine maxBound 1 -- True @@ -1639,7 +1658,7 @@ -- >>> defaultLayoutOptions -- LayoutOptions {layoutPageWidth = AvailablePerLine 80 1.0} defaultLayoutOptions :: LayoutOptions -defaultLayoutOptions = LayoutOptions { layoutPageWidth = AvailablePerLine 80 1 } +defaultLayoutOptions = LayoutOptions { layoutPageWidth = defaultPageWidth } -- | This is the default layout algorithm, and it is used by 'show', 'putDoc' -- and 'hPutDoc'. @@ -1654,9 +1673,7 @@ -> Doc ann -> SimpleDocStream ann layoutPretty = layoutWadlerLeijen - (FittingPredicate (\_pWidth _minNestingLevel maxWidth sdoc -> case maxWidth of - Nothing -> True - Just w -> fits w sdoc )) + (FittingPredicate (\_pWidth _minNestingLevel maxWidth sdoc -> fits maxWidth sdoc)) where fits :: Int -- ^ Width in which to fit the first line -> SimpleDocStream ann @@ -1674,7 +1691,7 @@ -- line breaks earlier if the content does not (or will not, rather) fit into -- one line. -- --- Considre the following python-ish document, +-- Consider the following python-ish document, -- -- >>> let fun x = hang 2 ("fun(" <> softline' <> x) <> ")" -- >>> let doc = (fun . fun . fun . fun . fun) (align (list ["abcdef", "ghijklm"])) @@ -1719,10 +1736,7 @@ :: LayoutOptions -> Doc ann -> SimpleDocStream ann -layoutSmart = layoutWadlerLeijen - (FittingPredicate (\pWidth minNestingLevel maxWidth sdoc -> case maxWidth of - Nothing -> True - Just w -> fits pWidth minNestingLevel w sdoc )) +layoutSmart = layoutWadlerLeijen (FittingPredicate fits) where -- Search with more lookahead: assuming that nesting roughly corresponds to -- syntactic depth, @fits@ checks that not only the current line fits, but @@ -1754,7 +1768,7 @@ -> Doc ann -> SimpleDocStream ann layoutWadlerLeijen - fittingPredicate + (FittingPredicate fits) LayoutOptions { layoutPageWidth = pWidth } doc = best 0 0 (Cons 0 doc Nil) @@ -1780,49 +1794,74 @@ Nest j x -> let !ij = i+j in best nl cc (Cons ij x ds) Union x y -> let x' = best nl cc (Cons i x ds) y' = best nl cc (Cons i y ds) - in selectNicer fittingPredicate nl cc x' y' + in selectNicer nl cc x' y' Column f -> best nl cc (Cons i (f cc) ds) WithPageWidth f -> best nl cc (Cons i (f pWidth) ds) Nesting f -> best nl cc (Cons i (f i) ds) Annotated ann x -> SAnnPush ann (best nl cc (Cons i x (UndoAnn ds))) selectNicer - :: FittingPredicate ann - -> Int -- ^ Current nesting level + :: Int -- ^ Current nesting level -> Int -- ^ Current column -> SimpleDocStream ann -- ^ Choice A. Invariant: first lines should not be longer than B's. -> SimpleDocStream ann -- ^ Choice B. -> SimpleDocStream ann -- ^ Choice A if it fits, otherwise B. - selectNicer (FittingPredicate fits) lineIndent currentColumn x y - | fits pWidth minNestingLevel availableWidth x = x - | otherwise = y + selectNicer lineIndent currentColumn x y = case pWidth of + AvailablePerLine lineLength ribbonFraction + | fits pWidth minNestingLevel availableWidth x -> x + where + minNestingLevel = + -- See https://github.com/quchen/prettyprinter/issues/83. + if startsWithLine y + -- y might be a (more compact) hanging layout. Let's check x + -- thoroughly with the smaller lineIndent. + then lineIndent + -- y definitely isn't a hanging layout. Let's allow the first + -- line of x to be checked on its own and format it consistently + -- with subsequent lines with the same indentation. + else currentColumn + availableWidth = min columnsLeftInLine columnsLeftInRibbon + where + columnsLeftInLine = lineLength - currentColumn + columnsLeftInRibbon = lineIndent + ribbonWidth - currentColumn + ribbonWidth = + (max 0 . min lineLength . round) + (fromIntegral lineLength * ribbonFraction) + Unbounded + -- See the Note [Detecting failure with Unbounded page width]. + | not (failsOnFirstLine x) -> x + _ -> y + + failsOnFirstLine :: SimpleDocStream ann -> Bool + failsOnFirstLine = go where - minNestingLevel = - -- See https://github.com/quchen/prettyprinter/issues/83. - if startsWithLine y - -- y might be a (more compact) hanging layout. Let's check x - -- thoroughly with the smaller lineIndent. - then lineIndent - -- y definitely isn't a hanging layout. Let's allow the first - -- line of x to be checked on its own and format it consistently - -- with subsequent lines with the same indentation. - else currentColumn - ribbonWidth = case pWidth of - AvailablePerLine lineLength ribbonFraction -> - (Just . max 0 . min lineLength . round) - (fromIntegral lineLength * ribbonFraction) - Unbounded -> Nothing - availableWidth = do - columnsLeftInLine <- case pWidth of - AvailablePerLine cpl _ribbonFrac -> Just (cpl - currentColumn) - Unbounded -> Nothing - columnsLeftInRibbon <- do - li <- Just lineIndent - rw <- ribbonWidth - cc <- Just currentColumn - Just (li + rw - cc) - Just (min columnsLeftInLine columnsLeftInRibbon) + go sds = case sds of + SFail -> True + SEmpty -> False + SChar _ s -> go s + SText _ _ s -> go s + SLine _ _ -> False + SAnnPush _ s -> go s + SAnnPop s -> go s + +-- Note [Detecting failure with Unbounded page width] +-- +-- To understand why it is sufficient to check the first line of the +-- SimpleDocStream, trace how an SFail ends up there: +-- +-- 1. We group a Doc containing a Line, producing a (Union x y) where +-- x contains Fail. +-- +-- 2. In best, any Unions are handled recursively, rejecting any +-- alternatives that would result in SFail. +-- +-- So once a SimpleDocStream reaches selectNicer, any SFail in it must +-- appear before the first linebreak – any other SFail would have been +-- detected and rejected in a previous iteration. + + + -- | @(layoutCompact x)@ lays out the document @x@ without adding any -- indentation. Since no \'pretty\' printing is involved, this layouter is very -- fast. The resulting output contains fewer characters than a prettyprinted @@ -1881,7 +1920,6 @@ SLine i x -> showString ('\n' : replicate i ' ') . renderShowS x SAnnPush _ x -> renderShowS x SAnnPop x -> renderShowS x - -- $setup diff --git a/src/Data/Text/Prettyprint/Doc/Internal/Debug.hs b/src/Data/Text/Prettyprint/Doc/Internal/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Prettyprint/Doc/Internal/Debug.hs @@ -0,0 +1,95 @@ +-- | __Warning: internal module!__ This means that the API may change +-- arbitrarily between versions without notice. Depending on this module may +-- lead to unexpected breakages, so proceed with caution! +-- +-- This module provides debugging helpers for inspecting 'Doc's. +-- +-- Use the @pretty-simple@ package to get a nicer layout for 'show'n +-- 'Diag's: +-- +-- >>> Text.Pretty.Simple.pPrintNoColor . diag $ align (vcat ["foo", "bar"]) +-- Column +-- [ +-- ( 10 +-- , Nesting +-- [ +-- ( 10 +-- , Cat ( Text 3 "foo" ) +-- ( Cat ( FlatAlt Line Empty ) ( Text 3 "bar" ) ) +-- ) +-- ] +-- ) +-- ] + + +module Data.Text.Prettyprint.Doc.Internal.Debug where + +import Data.Text (Text) +import Data.Text.Prettyprint.Doc.Internal (PageWidth, Doc) +import qualified Data.Text.Prettyprint.Doc.Internal as Doc + +-- | A variant of 'Doc' for debugging. +-- +-- Unlike in the 'Doc' type, the 'Column', 'WithPageWidth' and 'Nesting' +-- constructors don't contain functions but are \"sampled\" to allow +-- simple inspection with 'show'. +data Diag ann = + Fail + | Empty + | Char !Char + | Text !Int !Text + | Line + | FlatAlt (Diag ann) (Diag ann) + | Cat (Diag ann) (Diag ann) + | Nest !Int (Diag ann) + | Union (Diag ann) (Diag ann) + | Column [(Int, Diag ann)] + -- ^ 'Doc': @(Int -> Diag ann)@ + | WithPageWidth [(PageWidth, Diag ann)] + -- ^ 'Doc': @(PageWidth -> Diag ann)@ + | Nesting [(Int, Diag ann)] + -- ^ 'Doc': @(Int -> Diag ann)@ + | Annotated ann (Diag ann) + deriving Show + +-- | Convert a 'Doc' to its diagnostic representation. +-- +-- The functions in the 'Column', 'WithPageWidth' and 'Nesting' constructors are +-- sampled with some default values. +-- +-- Use `diag'` to control the function inputs yourself. +-- +-- >>> diag $ align (vcat ["foo", "bar"]) +-- Column [(10,Nesting [(10,Cat (Text 3 "foo") (Cat (FlatAlt Line Empty) (Text 3 "bar")))])] +diag :: Doc ann -> Diag ann +diag = diag' [10] [Doc.defaultPageWidth] [10] + +diag' + :: [Int] + -- ^ Cursor positions for the 'Column' constructor + -> [PageWidth] + -- ^ For 'WithPageWidth' + -> [Int] + -- ^ Nesting levels for 'Nesting' + -> Doc ann + -> Diag ann +diag' columns pageWidths nestings = go + where + go doc = case doc of + Doc.Fail -> Fail + Doc.Empty -> Empty + Doc.Char c -> Char c + Doc.Text l t -> Text l t + Doc.Line -> Line + Doc.FlatAlt a b -> FlatAlt (go a) (go b) + Doc.Cat a b -> Cat (go a) (go b) + Doc.Nest i d -> Nest i (go d) + Doc.Union a b -> Union (go a) (go b) + Doc.Column f -> Column (apply f columns) + Doc.WithPageWidth f -> WithPageWidth (apply f pageWidths) + Doc.Nesting f -> Nesting (apply f nestings) + Doc.Annotated ann d -> Annotated ann (go d) + + apply :: (a -> Doc ann) -> [a] -> [(a, Diag ann)] + apply f = map (\x -> (x, go (f x))) + diff --git a/src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs b/src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs --- a/src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs +++ b/src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs @@ -18,11 +18,7 @@ -- source form. module Data.Text.Prettyprint.Doc.Render.Tutorials.StackMachineTutorial {-# DEPRECATED "Writing your own stack machine is probably more efficient and customizable; also consider using »renderSimplyDecorated(A)« instead" #-} - ( - module Data.Text.Prettyprint.Doc.Render.Tutorials.StackMachineTutorial -) where - - + where import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -36,11 +32,9 @@ import Control.Applicative #endif - - --- $standalone-text +-- * The type of available markup -- --- = The type of available markup +-- $standalone-text -- -- First, we define a set of valid annotations must be defined, with the goal of -- defining a @'Doc' 'SimpleHtml'@. We will later define how to convert this to @@ -49,11 +43,7 @@ data SimpleHtml = Bold | Italics | Color Color | Paragraph | Headline data Color = Red | Green | Blue - - --- $standalone-text --- --- == Conveinence definitions +-- ** Convenience definitions bold, italics, paragraph, headline :: Doc SimpleHtml -> Doc SimpleHtml bold = annotate Bold @@ -64,11 +54,9 @@ color :: Color -> Doc SimpleHtml -> Doc SimpleHtml color c = annotate (Color c) - - --- $standalone-text +-- * The rendering algorithm -- --- = The rendering algorithm +-- $standalone-text -- -- With the annotation definitions out of the way, we can now define a -- conversion function from 'SimpleDocStream' annotated with our 'SimpleHtml' to the @@ -149,9 +137,9 @@ <> show (length remainingStyles) <> " unpaired styles! Please report this as a bug.") --- $standalone-text +-- * Example invocation -- --- = Example invocation +-- $standalone-text -- -- We can now render an example document using our definitions: -- diff --git a/src/Data/Text/Prettyprint/Doc/Render/Tutorials/TreeRenderingTutorial.hs b/src/Data/Text/Prettyprint/Doc/Render/Tutorials/TreeRenderingTutorial.hs --- a/src/Data/Text/Prettyprint/Doc/Render/Tutorials/TreeRenderingTutorial.hs +++ b/src/Data/Text/Prettyprint/Doc/Render/Tutorials/TreeRenderingTutorial.hs @@ -13,11 +13,7 @@ -- -- The module is written to be readable top-to-bottom in both Haddock and raw -- source form. -module Data.Text.Prettyprint.Doc.Render.Tutorials.TreeRenderingTutorial ( - module Data.Text.Prettyprint.Doc.Render.Tutorials.TreeRenderingTutorial -) where - - +module Data.Text.Prettyprint.Doc.Render.Tutorials.TreeRenderingTutorial where import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -33,11 +29,9 @@ import Data.Semigroup #endif - - --- $standalone-text +-- * The type of available markup -- --- = The type of available markup +-- $standalone-text -- -- First, we define a set of valid annotations must be defined, with the goal of -- defining a @'Doc' 'SimpleHtml'@. We will later define how to convert this to @@ -46,11 +40,7 @@ data SimpleHtml = Bold | Italics | Color Color | Paragraph | Headline data Color = Red | Green | Blue - - --- $standalone-text --- --- == Conveinence definitions +-- ** Convenience definitions bold, italics, paragraph, headline :: Doc SimpleHtml -> Doc SimpleHtml bold = annotate Bold @@ -61,9 +51,10 @@ color :: Color -> Doc SimpleHtml -> Doc SimpleHtml color c = annotate (Color c) - --- = The rendering algorithm +-- * The rendering algorithm -- +-- $standalone-text +-- -- With the annotation definitions out of the way, we can now define a -- conversion function from 'SimpleDocStream' (annotated with our 'SimpleHtml') -- to the tree-shaped 'SimpleDocTree', which is easily convertible to a @@ -116,9 +107,9 @@ Green -> "#0f0" Blue -> "#00f" --- $standalone-text +-- * Example invocation -- --- = Example invocation +-- $standalone-text -- -- We can now render an example document using our definitions: -- diff --git a/test/Testsuite/Main.hs b/test/Testsuite/Main.hs --- a/test/Testsuite/Main.hs +++ b/test/Testsuite/Main.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} #include "version-compatibility-macros.h" @@ -14,9 +15,13 @@ import Data.Word import System.Timeout (timeout) -import Data.Text.Prettyprint.Doc -import Data.Text.Prettyprint.Doc.Render.Text +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Internal +import Data.Text.Prettyprint.Doc.Internal.Debug +import Data.Text.Prettyprint.Doc.Render.Text +import Data.Text.Prettyprint.Doc.Render.Util.StackMachine (renderSimplyDecorated) +import Test.QuickCheck.Instances.Text () import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck @@ -80,32 +85,37 @@ , testCase "Preserve leading indentation" removeTrailingWhitespacePreserveIndentation ] + , testGroup "Unbounded layout of hard linebreak within `group` fails (#91)" + [ testCase "Line" regressionUnboundedGroupedLine + , testCase "Line within align" regressionUnboundedGroupedLineWithinAlign + ] ] ] fusionDoesNotChangeRendering :: FusionDepth -> Property fusionDoesNotChangeRendering depth - = forAll document (\doc -> - let rendered = render doc + = forAllShow (arbitrary :: Gen (Doc Int)) (show . diag) (\doc -> + forAll arbitrary (\layouter -> + let tShow = T.pack . show + render = renderSimplyDecorated id tShow tShow . layout layouter + rendered = render doc renderedFused = render (fuse depth doc) in counterexample (mkCounterexample rendered renderedFused) - (render doc == render (fuse depth doc)) ) + (render doc == render (fuse depth doc)) )) where - render = renderStrict . layoutPretty defaultLayoutOptions mkCounterexample rendered renderedFused - = (T.unpack . render . vsep) + = (T.unpack . renderStrict . layoutPretty defaultLayoutOptions . vsep) [ "Unfused and fused documents render differently!" , "Unfused:" , indent 4 (pretty rendered) , "Fused:" , indent 4 (pretty renderedFused) ] -newtype RandomDoc ann = RandomDoc (Doc ann) - -instance Arbitrary (RandomDoc ann) where - arbitrary = fmap RandomDoc document +instance Arbitrary ann => Arbitrary (Doc ann) where + arbitrary = document + shrink = genericShrink -- Possibly not a good idea, may break invariants -document :: Gen (Doc ann) +document :: Arbitrary ann => Gen (Doc ann) document = (dampen . frequency) [ (20, content) , (1, newlines) @@ -114,8 +124,12 @@ , (20, concatenationOfTwo) , (5, concatenationOfMany) , (1, enclosingOfOne) - , (1, enclosingOfMany) ] + , (1, enclosingOfMany) + , (1, annotated) ] +annotated :: Arbitrary ann => Gen (Doc ann) +annotated = annotate <$> arbitrary <*> document + content :: Gen (Doc ann) content = frequency [ (1, pure emptyDoc) @@ -137,24 +151,24 @@ , (1, pure softline') , (1, pure hardline) ] -nestingAndAlignment :: Gen (Doc ann) +nestingAndAlignment :: Arbitrary ann => Gen (Doc ann) nestingAndAlignment = frequency [ (1, nest <$> arbitrary <*> concatenationOfMany) , (1, group <$> document) , (1, hang <$> arbitrary <*> concatenationOfMany) , (1, indent <$> arbitrary <*> concatenationOfMany) ] -grouping :: Gen (Doc ann) +grouping :: Arbitrary ann => Gen (Doc ann) grouping = frequency [ (1, align <$> document) , (1, flatAlt <$> document <*> document) ] -concatenationOfTwo :: Gen (Doc ann) +concatenationOfTwo :: Arbitrary ann => Gen (Doc ann) concatenationOfTwo = frequency [ (1, (<>) <$> document <*> document) , (1, (<+>) <$> document <*> document) ] -concatenationOfMany :: Gen (Doc ann) +concatenationOfMany :: Arbitrary ann => Gen (Doc ann) concatenationOfMany = frequency [ (1, hsep <$> listOf document) , (1, vsep <$> listOf document) @@ -165,7 +179,7 @@ , (1, fillCat <$> listOf document) , (1, cat <$> listOf document) ] -enclosingOfOne :: Gen (Doc ann) +enclosingOfOne :: Arbitrary ann => Gen (Doc ann) enclosingOfOne = frequency [ (1, squotes <$> document) , (1, dquotes <$> document) @@ -174,12 +188,65 @@ , (1, brackets <$> document) , (1, braces <$> document) ] -enclosingOfMany :: Gen (Doc ann) +enclosingOfMany :: Arbitrary ann => Gen (Doc ann) enclosingOfMany = frequency [ (1, encloseSep <$> document <*> document <*> pure ", " <*> listOf document) , (1, list <$> listOf document) , (1, tupled <$> listOf document) ] +-- A 'show'able type representing a layout algorithm. +data Layouter ann + = LayoutPretty LayoutOptions + | LayoutSmart LayoutOptions + | LayoutCompact + | LayoutWadlerLeijen (FittingPredicate ann) LayoutOptions + deriving Show + +instance Show (FittingPredicate ann) where + show _ = "" + +instance Arbitrary (Layouter ann) where + arbitrary = oneof + [ LayoutPretty <$> arbitrary + , LayoutSmart <$> arbitrary + , pure LayoutCompact + -- This produces inconsistent layouts that break the fusionDoesNotChangeRendering test + -- , LayoutWadlerLeijen <$> arbitrary <*> arbitrary + ] + +layout :: Layouter ann -> Doc ann -> SimpleDocStream ann +layout (LayoutPretty opts) = layoutPretty opts +layout (LayoutSmart opts) = layoutSmart opts +layout LayoutCompact = layoutCompact +layout (LayoutWadlerLeijen fp opts) = layoutWadlerLeijen fp opts + +instance Arbitrary LayoutOptions where + arbitrary = LayoutOptions <$> oneof + [ AvailablePerLine <$> arbitrary <*> arbitrary + , pure Unbounded + ] + +instance Arbitrary (FittingPredicate ann) where + arbitrary = FittingPredicate <$> arbitrary + +instance CoArbitrary (SimpleDocStream ann) where + coarbitrary s0 = case s0 of + SFail -> variant' 0 + SEmpty -> variant' 1 + SChar _c s -> variant' 2 . coarbitrary s + SText l _t s -> variant' 3 . coarbitrary (l, s) + SLine i s -> variant' 4 . coarbitrary (i, s) + SAnnPush _a s -> variant' 5 . coarbitrary s + SAnnPop s -> variant' 6 . coarbitrary s + +instance CoArbitrary PageWidth where + coarbitrary (AvailablePerLine a b) = variant' 0 . coarbitrary (a, b) + coarbitrary Unbounded = variant' 1 + +-- | Silences type defaulting warnings for 'variant' +variant' :: Int -> Gen a -> Gen a +variant' = variant + -- QuickCheck 2.8 does not have 'scale' yet, so for compatibility with older -- releases we hand-code it here dampen :: Gen a -> Gen a @@ -296,3 +363,17 @@ = let sdoc :: SimpleDocStream () sdoc = SLine 2 (SChar 'x' SEmpty) in assertEqual "" sdoc (removeTrailingWhitespace sdoc) + +regressionUnboundedGroupedLine :: Assertion +regressionUnboundedGroupedLine + = let sdoc :: SimpleDocStream () + sdoc = layoutPretty (LayoutOptions Unbounded) (group hardline) + in assertEqual "" (SLine 0 SEmpty) sdoc + +regressionUnboundedGroupedLineWithinAlign :: Assertion +regressionUnboundedGroupedLineWithinAlign + = let doc :: Doc () + doc = group (align ("x" <> hardline <> "y")) + sdoc = layoutPretty (LayoutOptions Unbounded) doc + expected = SChar 'x' (SLine 0 (SChar 'y' SEmpty)) + in assertEqual "" expected sdoc