From 9a2810c0a5997a997736f0f18aeb02657df58838 Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Fri, 8 Nov 2019 02:58:31 +0100 Subject: [PATCH] Fix Unbounded layouts of hard linebreaks within `group` Previously, using layoutPretty or layoutSmart with an `Unbounded` page width would fail when the document contained a hard line break (`hardline`). `Unbounded` caused a shortcutting behaviour in the `FittingPredicate`s of these layouters that didn't check whether the layout might fail. This patch changes `layoutWadlerLeijen.selectNicer` to handle `Unbounded` page widths separately, allowing a simplification of the `FittingPredicate` type. Fixes #91. --- .../src/Data/Text/Prettyprint/Doc/Internal.hs | 104 +++++++++++------- prettyprinter/test/Testsuite/Main.hs | 20 +++- 2 files changed, 81 insertions(+), 43 deletions(-) diff --git a/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs b/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs index 9552ff50..5bb53ada 100755 --- a/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs +++ b/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs @@ -1585,11 +1585,11 @@ instance Traversable SimpleDocStream where -- -- - 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 @@ -1655,9 +1655,7 @@ layoutPretty -> 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 @@ -1675,7 +1673,7 @@ layoutPretty = layoutWadlerLeijen -- 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"])) @@ -1720,10 +1718,7 @@ layoutSmart :: 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 @@ -1755,7 +1750,7 @@ layoutWadlerLeijen -> Doc ann -> SimpleDocStream ann layoutWadlerLeijen - fittingPredicate + (FittingPredicate fits) LayoutOptions { layoutPageWidth = pWidth } doc = best 0 0 (Cons 0 doc Nil) @@ -1781,48 +1776,73 @@ layoutWadlerLeijen 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 diff --git a/prettyprinter/test/Testsuite/Main.hs b/prettyprinter/test/Testsuite/Main.hs index 1f763b1c..d8492d32 100644 --- a/prettyprinter/test/Testsuite/Main.hs +++ b/prettyprinter/test/Testsuite/Main.hs @@ -85,6 +85,10 @@ tests = testGroup "Tests" , testCase "Preserve leading indentation" removeTrailingWhitespacePreserveIndentation ] + , testGroup "Unbounded layout of hard linebreak within `group` fails (#91)" + [ testCase "Line" regressionUnboundedGroupedLine + , testCase "Line within align" regressionUnboundedGroupedLineWithinAlign + ] ] ] @@ -219,7 +223,7 @@ layout (LayoutWadlerLeijen fp opts) = layoutWadlerLeijen fp opts instance Arbitrary LayoutOptions where arbitrary = LayoutOptions <$> oneof [ AvailablePerLine <$> arbitrary <*> arbitrary - -- , pure Unbounded -- https://github.com/quchen/prettyprinter/issues/91 + , pure Unbounded ] instance Arbitrary (FittingPredicate ann) where @@ -359,3 +363,17 @@ removeTrailingWhitespacePreserveIndentation = 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