prettyprinter 1 → 1.0.1
raw patch · 5 files changed
+310/−215 lines, 5 filesdep +tasty-hunitdep ~base
Dependencies added: tasty-hunit
Dependency ranges changed: base
Files
- prettyprinter.cabal +38/−27
- src/Data/Text/Prettyprint/Doc.hs +14/−9
- src/Data/Text/Prettyprint/Doc/Internal.hs +200/−151
- src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs +29/−23
- test/Testsuite/Main.hs +29/−5
prettyprinter.cabal view
@@ -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
src/Data/Text/Prettyprint/Doc.hs view
@@ -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 --
src/Data/Text/Prettyprint/Doc/Internal.hs view
@@ -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.
src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs view
@@ -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
test/Testsuite/Main.hs view
@@ -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