diff --git a/prettyprinter.cabal b/prettyprinter.cabal --- a/prettyprinter.cabal +++ b/prettyprinter.cabal @@ -1,8 +1,8 @@ name: prettyprinter -version: 1 +version: 1.0.1 cabal-version: >= 1.10 category: User Interfaces, Text -synopsis: A modern, extensible and well-documented prettyprinter. +synopsis: A modern, easy to use, well-documented, extensible prettyprinter. description: See README.md license: BSD2 license-file: LICENSE.md @@ -53,8 +53,8 @@ , ScopedTypeVariables build-depends: - base < 127 - , text + base >= 4.7 && < 5 + , text == 1.2.* if impl(ghc >= 8.0) ghc-options: -Wcompat @@ -65,19 +65,27 @@ +Flag buildReadme + Description: Build the readme generator + Default: False + + executable generate_readme hs-source-dirs: app main-is: GenerateReadme.hs build-depends: - base < 127 + base >= 4.7 && < 5 , prettyprinter - , text - , template-haskell + + , text == 1.2.* + , template-haskell >= 2.9 && < 2.12 default-language: Haskell2010 other-modules: MultilineTh other-extensions: OverloadedStrings , TemplateHaskell - if impl (ghc < 7.10) + if flag(buildReadme) + buildable: True + else buildable: False @@ -87,8 +95,8 @@ hs-source-dirs: test/Doctest main-is: Main.hs build-depends: - base < 127 - , doctest >= 0.9 + base >= 4.7 && < 5 + , doctest >= 0.9 && < 0.12 , QuickCheck >= 2.7 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 @@ -104,16 +112,17 @@ base , prettyprinter - , pgp-wordlist - , bytestring - , tasty - , tasty-quickcheck - , text + , pgp-wordlist == 0.1.* + , bytestring == 0.10.* + , tasty >= 0.10 && < 0.12 + , tasty-hunit == 0.9.* + , tasty-quickcheck == 0.8.* + , text == 1.2.* ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall default-language: Haskell2010 if impl(ghc < 8.0) - build-depends: semigroups >= 0.1 && < 0.19 + build-depends: semigroups >= 0.6 && < 0.19 @@ -122,24 +131,26 @@ hs-source-dirs: bench main-is: Fusion.hs build-depends: - base + base >= 4.7 && < 5 , prettyprinter - , criterion - , mtl - , random - , text - , transformers - , ansi-wl-pprint + , criterion >= 1.1 && < 1.3 + , mtl >= 2.1 && < 2.3 + , random >= 1.0 && < 1.2 + , text == 1.2.* + , transformers >= 0.3 && < 0.6 + , ansi-wl-pprint == 0.6.* ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 other-extensions: NumDecimals, OverloadedStrings benchmark faster-unsafe-text - build-depends: base >= 4.7 && < 5 - , criterion - , text - , prettyprinter + build-depends: + base >= 4.7 && < 5 + , prettyprinter + + , criterion >= 1.1 && < 1.3 + , text == 1.2.* hs-source-dirs: bench main-is: FasterUnsafeText.hs 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 @@ -83,15 +83,18 @@ -- │ 'SimpleDocStream' │ -- │ (simple document) │ -- ╰─────────┬─────────╯ --- │ --- │ Renderers --- │ --- ╭───────────────────┼───────────────────╮ --- │ │ │ --- ▽ ▽ ▽ --- ╭───────────────╮ ╭───────────────╮ ╭───────────────╮ --- │ Plain 'Text' │ │ ANSI terminal │ │ other/custom │ --- ╰───────────────╯ ╰───────────────╯ ╰───────────────╯ +-- ╭───────────────────┤ +-- │ │ +-- 'Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.treeForm' │ │ +-- ▽ │ Renderers +-- ╭───────────────╮ │ +-- │ 'Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.SimpleDocTree' │ │ +-- ╰───────┬───────╯ ├───────────────────┬───────────────────╮ +-- │ │ │ │ +-- ▽ ▽ ▽ ▽ +-- ╭───────────────╮ ╭───────────────╮ ╭───────────────╮ ╭───────────────╮ +-- │ HTML │ │ Plain 'Text' │ │ ANSI terminal │ │ other/custom │ +-- ╰───────────────╯ ╰───────────────╯ ╰───────────────╯ ╰───────────────╯ -- @ -- -- = How the layout works @@ -195,8 +198,10 @@ annotate, unAnnotate, reAnnotate, + alterAnnotations, unAnnotateS, reAnnotateS, + alterAnnotationsS, -- * Optimization -- 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 @@ -22,16 +22,17 @@ +import Control.Applicative import Data.Int -import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe -import Data.String (IsString (..)) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Lazy as Lazy +import Data.String (IsString (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as Lazy import Data.Void import Data.Word -import GHC.Generics (Generic) +import GHC.Generics (Generic) -- Depending on the Cabal file, this might be from base, or for older builds, -- from the semigroups package. @@ -41,10 +42,6 @@ import Numeric.Natural #endif -#if !(APPLICATIVE_MONAD) -import Control.Applicative -#endif - #if !(FOLDABLE_TRAVERSABLE_IN_PRELUDE) import Data.Foldable (Foldable (..)) import Data.Traversable (Traversable (..)) @@ -253,19 +250,19 @@ viaShow = pretty . T.pack . show -- | Convert a 'Show'able value /that must not contain newlines/ to a 'Doc'. --- If there are newlines, use 'viaShow' instead. +-- If there may be newlines, use 'viaShow' instead. unsafeViaShow :: Show a => a -> Doc ann unsafeViaShow = unsafeTextWithoutNewlines . T.pack . show -- | >>> pretty (123 :: Int) -- 123 -instance Pretty Int where pretty = unsafeViaShow -instance Pretty Int8 where pretty = unsafeViaShow -instance Pretty Int16 where pretty = unsafeViaShow -instance Pretty Int32 where pretty = unsafeViaShow -instance Pretty Int64 where pretty = unsafeViaShow -instance Pretty Word where pretty = unsafeViaShow -instance Pretty Word8 where pretty = unsafeViaShow +instance Pretty Int where pretty = unsafeViaShow +instance Pretty Int8 where pretty = unsafeViaShow +instance Pretty Int16 where pretty = unsafeViaShow +instance Pretty Int32 where pretty = unsafeViaShow +instance Pretty Int64 where pretty = unsafeViaShow +instance Pretty Word where pretty = unsafeViaShow +instance Pretty Word8 where pretty = unsafeViaShow instance Pretty Word16 where pretty = unsafeViaShow instance Pretty Word32 where pretty = unsafeViaShow instance Pretty Word64 where pretty = unsafeViaShow @@ -357,7 +354,11 @@ -- | (lazy 'Text' instance, identical to the strict version) instance Pretty Lazy.Text where pretty = pretty . Lazy.toStrict --- | I tried finding a good example to show here but could not find one +-- | Finding a good example for printing something that does not exist is hard, +-- so here is an example of printing a list full of nothing. +-- +-- >>> pretty ([] :: [Void]) +-- [] instance Pretty Void where pretty = absurd @@ -403,7 +404,8 @@ :: Int -- ^ Change of nesting level -> Doc ann -> Doc ann -nest = Nest +nest 0 x = x -- Optimization +nest i x = Nest i x -- | The @'line'@ document advances to the next line and indents to the current -- nesting level. @@ -498,29 +500,74 @@ -- See 'vcat', 'line', or 'flatAlt' for examples that are related, or make good -- use of it. group :: Doc ann -> Doc ann -group x = Union (flatten x) x +-- See note [Group: special flattening] +group x = case changesUponFlattening x of + Nothing -> x + Just x' -> Union x' x --- Choose the first element of each @Union@, and discard the first field of all --- @FlatAlt@s. -flatten :: Doc ann -> Doc ann -flatten = \case - FlatAlt _ y -> flatten y - Cat x y -> Cat (flatten x) (flatten y) - Nest i x -> Nest i (flatten x) - Line -> Fail - Union x _ -> flatten x - Column f -> Column (flatten . f) - WithPageWidth f -> WithPageWidth (flatten . f) - Nesting f -> Nesting (flatten . f) - Annotated ann x -> Annotated ann (flatten x) +-- Note [Group: special flattening] +-- +-- Since certain documents do not change under removal of newlines etc, there is +-- no point in creating a 'Union' of the flattened and unflattened version – all +-- this does is introducing two branches for the layout algorithm to take, +-- resulting in potentially exponential behavior on deeply nested examples, such +-- as +-- +-- pathological n = iterate (\x -> hsep [x, sep []] ) "foobar" !! n +-- +-- See https://github.com/quchen/prettyprinter/issues/22 for the corresponding +-- ticket. - x@Fail -> x - x@Empty -> x - x@Char{} -> x - x@Text{} -> x +-- | 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) +changesUponFlattening = \case + FlatAlt _ y -> Just (flatten y) + Line -> Just Fail + Union x _ -> changesUponFlattening x <|> Just 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)) + 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') + Empty -> Nothing + Char{} -> Nothing + Text{} -> Nothing + Fail -> Nothing + where + -- Flatten, but don’t report whether anything changes. + flatten :: Doc ann -> Doc ann + flatten = \case + FlatAlt _ y -> flatten y + Cat x y -> Cat (flatten x) (flatten y) + Nest i x -> Nest i (flatten x) + Line -> Fail + Union x _ -> flatten x + Column f -> Column (flatten . f) + WithPageWidth f -> WithPageWidth (flatten . f) + Nesting f -> Nesting (flatten . f) + Annotated ann x -> Annotated ann (flatten x) + + x@Fail -> x + x@Empty -> x + x@Char{} -> x + x@Text{} -> x + + + -- | @('flatAlt' x fallback)@ renders as @x@ by default, but falls back to -- @fallback@ when 'group'ed. Since the layout algorithms rely on 'group' having -- an effect of shortening the width of the contained text, careless usage of @@ -1064,17 +1111,17 @@ -- -- >>> let things = [True] -- >>> let amount = length things --- >>> "The list has" <+> pretty amount <+> plural "entry" "entries" amount --- The list has 1 entry +-- >>> pretty things <+> "has" <+> pretty amount <+> plural "entry" "entries" amount +-- [True] has 1 entry plural :: (Num amount, Eq amount) => doc -- ^ @1@ case -> doc -- ^ other cases -> amount -> doc -plural one many n +plural one multiple n | n == 1 = one - | otherwise = many + | otherwise = multiple -- | @('enclose' l r x)@ encloses document @x@ between documents @l@ and @r@ -- using @'<>'@. @@ -1267,21 +1314,7 @@ -- entire contained document. If possible, it is preferrable to unannotate after -- producing the layout by using 'unAnnotateS'. unAnnotate :: Doc ann -> Doc xxx -unAnnotate = \case - Fail -> Fail - Empty -> Empty - Char c -> Char c - Text l t -> Text l t - Line -> Line - - FlatAlt x y -> FlatAlt (unAnnotate x) (unAnnotate y) - Cat x y -> Cat (unAnnotate x) (unAnnotate y) - Nest i x -> Nest i (unAnnotate x) - Union x y -> Union (unAnnotate x) (unAnnotate y) - Column f -> Column (unAnnotate . f) - WithPageWidth f -> WithPageWidth (unAnnotate . f) - Nesting f -> Nesting (unAnnotate . f) - Annotated _ x -> unAnnotate x +unAnnotate = alterAnnotations (const Nothing) -- | Change the annotation of a 'Doc'ument. -- @@ -1295,7 +1328,20 @@ -- Since @'reAnnotate'@ has the right type and satisfies @'reAnnotate id = id'@, -- it is used to define the @'Functor'@ instance of @'Doc'@. reAnnotate :: (ann -> ann') -> Doc ann -> Doc ann' -reAnnotate re = go +reAnnotate re = alterAnnotations (Just . re) + +-- | Change the annotation of a 'Doc'ument to a different one, or none at all. +-- +-- This is a general function that combines 'unAnnotate' and 'reAnnotate', and +-- it is useful for mapping semantic annotations (such as »this is a keyword«) +-- to display annotations (such as »this is red«), because some backends may not +-- care about certain annotations, while others may. +-- +-- Since this traverses the entire @'Doc'@ tree, including parts that are not +-- rendered due to other layouts fitting better, it is preferrable to reannotate +-- after producing the layout by using @'alterAnnotationsS'@. +alterAnnotations :: (ann -> Maybe ann') -> Doc ann -> Doc ann' +alterAnnotations re = go where go = \case Fail -> Fail @@ -1311,24 +1357,22 @@ Column f -> Column (go . f) WithPageWidth f -> WithPageWidth (go . f) Nesting f -> Nesting (go . f) - Annotated ann x -> Annotated (re ann) (go x) + Annotated ann x -> case re ann of + Nothing -> go x + Just ann' -> Annotated ann' (go x) -- | Remove all annotations. 'unAnnotate' for 'SimpleDocStream'. unAnnotateS :: SimpleDocStream ann -> SimpleDocStream xxx -unAnnotateS = go - where - go = \case - SFail -> SFail - SEmpty -> SEmpty - SChar c rest -> SChar c (go rest) - SText l t rest -> SText l t (go rest) - SLine l rest -> SLine l (go rest) - SAnnPush _ rest -> go rest - SAnnPop rest -> go rest +unAnnotateS = alterAnnotationsS (const Nothing) -- | Change the annotation of a document. 'reAnnotate' for 'SimpleDocStream'. reAnnotateS :: (ann -> ann') -> SimpleDocStream ann -> SimpleDocStream ann' -reAnnotateS f = go +reAnnotateS re = alterAnnotationsS (Just . re) + +-- | Change the annotation of a document to a different annotation, or none at +-- all. 'alterAnnotations' for 'SimpleDocStream'. +alterAnnotationsS :: (ann -> Maybe ann') -> SimpleDocStream ann -> SimpleDocStream ann' +alterAnnotationsS re = go where go = \case SFail -> SFail @@ -1336,9 +1380,10 @@ SChar c rest -> SChar c (go rest) SText l t rest -> SText l t (go rest) SLine l rest -> SLine l (go rest) - SAnnPush ann rest -> SAnnPush (f ann) (go rest) SAnnPop rest -> SAnnPop (go rest) - + SAnnPush ann rest -> case re ann of + Nothing -> go rest + Just ann' -> SAnnPush ann' (go rest) -- | Fusion depth parameter, used by 'fuse'. @@ -1474,33 +1519,42 @@ -- | Collect all annotations from a document. instance Foldable SimpleDocStream where - foldMap f = \case - SFail -> mempty - SEmpty -> mempty - SChar _ rest -> foldMap f rest - SText _ _ rest -> foldMap f rest - SLine _ rest -> foldMap f rest - SAnnPush ann rest -> f ann `mappend` foldMap f rest - SAnnPop rest -> foldMap f rest + foldMap f = go + where + go = \case + SFail -> mempty + SEmpty -> mempty + SChar _ rest -> go rest + SText _ _ rest -> go rest + SLine _ rest -> go rest + SAnnPush ann rest -> f ann `mappend` go rest + SAnnPop rest -> go rest -- | Transform a document based on its annotations, possibly leveraging -- 'Applicative' effects. instance Traversable SimpleDocStream where - traverse f = \case - SFail -> pure SFail - SEmpty -> pure SEmpty - SChar c rest -> SChar c <$> traverse f rest - SText l t rest -> SText l t <$> traverse f rest - SLine i rest -> SLine i <$> traverse f rest - SAnnPush ann rest -> SAnnPush <$> f ann <*> traverse f rest - SAnnPop rest -> SAnnPop <$> traverse f rest + traverse f = go + where + go = \case + SFail -> pure SFail + SEmpty -> pure SEmpty + SChar c rest -> SChar c <$> go rest + SText l t rest -> SText l t <$> go rest + SLine i rest -> SLine i <$> go rest + SAnnPush ann rest -> SAnnPush <$> f ann <*> go rest + SAnnPop rest -> SAnnPop <$> go rest -- | Decide whether a 'SimpleDocStream' fits the constraints given, namely -- -- - page width -- - minimum nesting level to fit in -- - width in which to fit the first line; Nothing is unbounded -newtype FittingPredicate ann = FP (PageWidth -> Int -> Maybe Int -> SimpleDocStream ann -> Bool) +newtype FittingPredicate ann + = FittingPredicate (PageWidth + -> Int + -> Maybe Int + -> SimpleDocStream ann + -> Bool) -- | List of nesting level/document pairs yet to be laid out. data LayoutPipeline ann = @@ -1558,24 +1612,22 @@ :: LayoutOptions -> Doc ann -> SimpleDocStream ann -layoutPretty = layout fits1 +layoutPretty = layoutWadlerLeijen + (FittingPredicate (\_pWidth _minNestingLevel maxWidth sdoc -> case maxWidth of + Nothing -> True + Just w -> fits w sdoc )) where - -- | @fits1@ does 1 line lookahead. - fits1 :: FittingPredicate ann - fits1 = FP (\_p _m w -> go w) - where - go :: Maybe Int -- ^ Width in which to fit the first line; Nothing is infinite - -> SimpleDocStream ann - -> Bool - go Nothing _ = True - go (Just w) _ | w < 0 = False - go _ SFail = False - go _ SEmpty = True - go (Just w) (SChar _ x) = go (Just (w - 1)) x - go (Just w) (SText l _t x) = go (Just (w - l)) x - go _ SLine{} = True - go (Just w) (SAnnPush _ x) = go (Just w) x - go (Just w) (SAnnPop x) = go (Just w) x + fits :: Int -- ^ Width in which to fit the first line + -> SimpleDocStream ann + -> Bool + fits w _ | w < 0 = False + fits _ SFail = False + fits _ SEmpty = True + fits w (SChar _ x) = fits (w - 1) x + fits w (SText l _t x) = fits (w - l) x + fits _ SLine{} = True + fits w (SAnnPush _ x) = fits w x + fits w (SAnnPop x) = fits w x -- | A layout algorithm with more lookahead than 'layoutPretty', that introduces -- line breaks earlier if the content does not (or will not, rather) fit into @@ -1626,44 +1678,41 @@ :: LayoutOptions -> Doc ann -> SimpleDocStream ann -layoutSmart = layout fitsR +layoutSmart = layoutWadlerLeijen + (FittingPredicate (\pWidth minNestingLevel maxWidth sdoc -> case maxWidth of + Nothing -> False + Just w -> fits pWidth minNestingLevel w sdoc )) where - -- @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). - fitsR :: FittingPredicate ann - fitsR = FP go - where - go :: PageWidth - -> Int -- ^ Minimum nesting level to fit in - -> Maybe Int -- ^ Width in which to fit the first line - -> SimpleDocStream ann - -> Bool - go _ _ Nothing _ = False - go _ _ (Just w) _ | w < 0 = False - go _ _ _ SFail = False - go _ _ _ SEmpty = True - go pw m (Just w) (SChar _ x) = go pw m (Just (w - 1)) x - go pw m (Just w) (SText l _t x) = go pw m (Just (w - l)) x - go pw m _ (SLine i x) - | m < i, AvailablePerLine cpl _ <- pw = go pw m (Just (cpl - i)) x - | otherwise = True - go pw m w (SAnnPush _ x) = go pw m w x - go pw m w (SAnnPop x) = go pw m w x - - + -- Search with more lookahead: assuming that nesting roughly corresponds to + -- syntactic depth, @fits@ 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). + fits :: PageWidth + -> Int -- ^ Minimum nesting level to fit in + -> Int -- ^ Width in which to fit the first line + -> SimpleDocStream ann + -> Bool + fits _ _ w _ | w < 0 = False + fits _ _ _ SFail = False + fits _ _ _ SEmpty = True + fits pw m w (SChar _ x) = fits pw m (w - 1) x + fits pw m w (SText l _t x) = fits pw m (w - l) x + fits pw m _ (SLine i x) + | m < i, AvailablePerLine cpl _ <- pw = fits pw m (cpl - i) x + | otherwise = True + fits pw m w (SAnnPush _ x) = fits pw m w x + fits pw m w (SAnnPop x) = fits pw m w x -layout +-- | The Wadler/Leijen layout algorithm +layoutWadlerLeijen :: forall ann. FittingPredicate ann -> LayoutOptions -> Doc ann -> SimpleDocStream ann -layout +layoutWadlerLeijen fittingPredicate LayoutOptions { layoutPageWidth = pWidth } doc @@ -1703,7 +1752,7 @@ -> 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 (FP fits) lineIndent currentColumn x y + selectNicer (FittingPredicate fits) lineIndent currentColumn x y | fits pWidth minNestingLevel availableWidth x = x | otherwise = y where @@ -1748,20 +1797,20 @@ layoutCompact doc = scan 0 [doc] where scan _ [] = SEmpty - scan !k (d:ds) = case d of + scan !col (d:ds) = case d of Fail -> SFail - Empty -> scan k ds - Char c -> SChar c (scan (k+1) ds) - Text l t -> let !k' = k+l in SText l t (scan k' ds) - FlatAlt x _ -> scan k (x:ds) + Empty -> scan col ds + Char c -> SChar c (scan (col+1) ds) + Text l t -> let !col' = col+l in SText l t (scan col' ds) + FlatAlt x _ -> scan col (x:ds) Line -> SLine 0 (scan 0 ds) - Cat x y -> scan k (x:y:ds) - Nest _ x -> scan k (x:ds) - Union _ y -> scan k (y:ds) - Column f -> scan k (f k:ds) - WithPageWidth f -> scan k (f Unbounded : ds) - Nesting f -> scan k (f 0 : ds) - Annotated _ x -> scan k (x:ds) + Cat x y -> scan col (x:y:ds) + Nest _ x -> scan col (x:ds) + Union _ y -> scan col (y:ds) + Column f -> scan col (f col:ds) + WithPageWidth f -> scan col (f Unbounded : ds) + Nesting f -> scan col (f 0 : ds) + Annotated _ x -> scan col (x:ds) -- | @('show' doc)@ prettyprints document @doc@ with 'defaultLayoutOptions', -- ignoring all annotations. diff --git a/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs b/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs --- a/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs +++ b/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs @@ -17,6 +17,7 @@ -- * Manipulating annotations unAnnotateST, reAnnotateST, + alterAnnotationsST, -- * Common use case shortcut definitions renderSimplyDecorated, @@ -216,43 +217,48 @@ -- | Remove all annotations. 'unAnnotate' for 'SimpleDocTree'. unAnnotateST :: SimpleDocTree ann -> SimpleDocTree xxx -unAnnotateST = \case - STEmpty -> STEmpty - STChar c -> STChar c - STText l t -> STText l t - STLine i -> STLine i - STAnn _ rest -> unAnnotateST rest - STConcat xs -> STConcat (map unAnnotateST xs) +unAnnotateST = alterAnnotationsST (const Nothing) -- | Change the annotation of a document. 'reAnnotate' for 'SimpleDocTree'. reAnnotateST :: (ann -> ann') -> SimpleDocTree ann -> SimpleDocTree ann' -reAnnotateST f = go +reAnnotateST f = alterAnnotationsST (Just . f) + +-- | Change the annotation of a document to a different annotation, or none at +-- all. 'alterAnnotations' for 'SimpleDocTree'. +alterAnnotationsST :: (ann -> Maybe ann') -> SimpleDocTree ann -> SimpleDocTree ann' +alterAnnotationsST re = go where go = \case STEmpty -> STEmpty STChar c -> STChar c STText l t -> STText l t STLine i -> STLine i - STAnn ann rest -> STAnn (f ann) (go rest) STConcat xs -> STConcat (map go xs) + STAnn ann rest -> case re ann of + Nothing -> go rest + Just ann' -> STAnn ann' (go rest) -- | Collect all annotations from a document. instance Foldable SimpleDocTree where - foldMap f = \case - STEmpty -> mempty - STChar _ -> mempty - STText _ _ -> mempty - STLine _ -> mempty - STAnn ann rest -> f ann `mappend` foldMap f rest - STConcat xs -> mconcat (map (foldMap f) xs) + foldMap f = go + where + go = \case + STEmpty -> mempty + STChar _ -> mempty + STText _ _ -> mempty + STLine _ -> mempty + STAnn ann rest -> f ann `mappend` go rest + STConcat xs -> mconcat (map go xs) -- | Transform a document based on its annotations, possibly leveraging -- 'Applicative' effects. instance Traversable SimpleDocTree where - traverse f = \case - STEmpty -> pure STEmpty - STChar c -> pure (STChar c) - STText l t -> pure (STText l t) - STLine i -> pure (STLine i) - STAnn ann rest -> STAnn <$> f ann <*> traverse f rest - STConcat xs -> STConcat <$> traverse (traverse f) xs + traverse f = go + where + go = \case + STEmpty -> pure STEmpty + STChar c -> pure (STChar c) + STText l t -> pure (STText l t) + STLine i -> pure (STLine i) + STAnn ann rest -> STAnn <$> f ann <*> go rest + STConcat xs -> STConcat <$> traverse go xs diff --git a/test/Testsuite/Main.hs b/test/Testsuite/Main.hs --- a/test/Testsuite/Main.hs +++ b/test/Testsuite/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} #include "version-compatibility-macros.h" @@ -7,15 +8,18 @@ +import Control.Exception (evaluate) import qualified Data.ByteString.Lazy as BSL import qualified Data.Text as T import Data.Text.PgpWordlist import Data.Word +import System.Timeout (timeout) import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Text import Test.Tasty +import Test.Tasty.HUnit import Test.Tasty.QuickCheck #if !(APPLICATIVE_MONAD) @@ -31,11 +35,17 @@ main = defaultMain tests tests :: TestTree -tests = testGroup "Fusion" - [ testProperty "Shallow fusion does not change rendering" - (fusionDoesNotChangeRendering Shallow) - , testProperty "Deep fusion does not change rendering" - (fusionDoesNotChangeRendering Deep) +tests = testGroup "Tests" + [ testGroup "Fusion" + [ testProperty "Shallow fusion does not change rendering" + (fusionDoesNotChangeRendering Shallow) + , testProperty "Deep fusion does not change rendering" + (fusionDoesNotChangeRendering Deep) + ] + , testGroup "Regression tests" + [ testCase "Pathological grouping performance" + pathologicalGroupingPerformance + ] ] fusionDoesNotChangeRendering :: FusionDepth -> Property @@ -139,3 +149,17 @@ -- releases we hand-code it here dampen :: Gen a -> Gen a dampen gen = sized (\n -> resize ((n*2) `quot` 3) gen) + + + +-- Deeply nested group/flatten calls can result in exponential performance. +-- +-- See https://github.com/quchen/prettyprinter/issues/22 +pathologicalGroupingPerformance :: Assertion +pathologicalGroupingPerformance + = timeout 10000000 (poorMansForce (pathological 1000)) >>= \case + Nothing -> assertFailure "Timeout!" + Just _success -> pure () + where + pathological n = iterate (\x -> hsep [x, sep []] ) "foobar" !! n + poorMansForce = evaluate . length . show