prettyprinter 1.5.1 → 1.6.0

raw patch · 11 files changed

+350/−137 lines, 11 filesdep +gaugedep +quickcheck-instancesdep −criteriondep ~base-compatnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: gauge, quickcheck-instances

Dependencies removed: criterion

Dependency ranges changed: base-compat

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−0
• bench/FasterUnsafeText.hs +1/−1
• bench/Fusion.hs +3/−3
• bench/LargeOutput.hs +1/−2
• prettyprinter.cabal +7/−5
• src/Data/Text/Prettyprint/Doc.hs +3/−0
• src/Data/Text/Prettyprint/Doc/Internal.hs +107/−69
• src/Data/Text/Prettyprint/Doc/Internal/Debug.hs +95/−0
• src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs +8/−20
• src/Data/Text/Prettyprint/Doc/Render/Tutorials/TreeRenderingTutorial.hs +9/−18
• test/Testsuite/Main.hs +100/−19

@@ -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

@@ -4,7 +4,7 @@   -import           Criterion.Main+import           Gauge.Main import           Data.Char import           Data.Text                          (Text) import qualified Data.Text                          as T

@@ -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))

@@ -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

@@ -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

@@ -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 -- -- @

@@ -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

@@ -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)))+

@@ -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: --

@@ -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: --

@@ -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 _ = "<fitting predicate>"++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