From 99553dcfaa959f64c2165ecb054f679c2a8b6fb1 Mon Sep 17 00:00:00 2001 From: Jannis Date: Thu, 23 Jan 2020 21:22:20 +0100 Subject: [PATCH 1/8] Take 2 + property test --- .../src/Data/Text/Prettyprint/Doc/Internal.hs | 94 ++++++++++++++++++- prettyprinter/test/Testsuite/Main.hs | 14 +++ 2 files changed, 106 insertions(+), 2 deletions(-) diff --git a/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs b/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs index 74914b39..17599dd0 100755 --- a/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs +++ b/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs @@ -514,6 +514,96 @@ softline' = group line' hardline :: Doc ann hardline = Line +group :: Doc ann -> Doc ann +group = \doc -> case doc of + FlatAlt x y -> case changesOnFlattening x of + HasLine -> y + NoChange -> Union y x + Flat y' -> Union y' x + + x@(Cat a b) -> case (changesOnFlattening a, changesOnFlattening b) of + (HasLine , _ ) -> x + (_ , HasLine ) -> x + (NoChange , NoChange) -> x + (NoChange , Flat b' ) -> Cat a (Union b' b) + (Flat a' , NoChange) -> Cat (Union a' a) b + (Flat a' , Flat b' ) -> Union (Cat a' b') (Cat a b) + + Annotated ann x -> Annotated ann (group x) + Nest i x -> Nest i (group x) + + Column f -> Column (group . f) + Nesting f -> Nesting (group . f) + WithPageWidth f -> WithPageWidth (group . f) + + x@Union{} -> x + x@Char{} -> x + x@Text{} -> x + x@Line -> x + x@Empty -> x + -- Should never happen on a valid document + x@Fail -> x + +changesOnFlattening :: Doc ann -> FlatteningResult (Doc ann) +changesOnFlattening = \doc -> case doc of + FlatAlt _ y -> case changesOnFlattening y of + HasLine -> HasLine + NoChange -> Flat y + Flat y' -> Flat y' + + Union x _ -> Flat x + + Cat a b -> case (changesOnFlattening a, changesOnFlattening b) of + (HasLine , _ ) -> HasLine + (_ , HasLine ) -> HasLine + (NoChange , NoChange) -> NoChange + (Flat a' , NoChange) -> Flat (Cat a' b) + (NoChange , Flat b' ) -> Flat (Cat a b') + (Flat a' , Flat b' ) -> Flat (Cat a' b') + + Annotated ann x -> Annotated ann <$> (changesOnFlattening x) + Nest i x -> Nest i <$> (changesOnFlattening x) + + Column f -> Flat (Column (flatten . f)) + Nesting f -> Flat (Nesting (flatten . f)) + WithPageWidth f -> Flat (WithPageWidth (flatten . f)) + + Line -> HasLine + + -- Should actually be impossible here. HasLine has the same effect tho + Fail -> HasLine + + Text{} -> NoChange + Char{} -> NoChange + Empty -> NoChange + where + flatten :: Doc ann -> Doc ann + flatten = \doc -> case doc of + 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 + +data FlatteningResult a + = HasLine + | NoChange + | Flat a + +instance Functor FlatteningResult where + fmap _ HasLine = HasLine + fmap _ NoChange = NoChange + fmap f (Flat a) = Flat (f a) + -- | @('group' x)@ tries laying out @x@ into a single line by removing the -- contained line breaks; if this does not fit the page, @x@ is laid out without -- any changes. The 'group' function is key to layouts that adapt to available @@ -521,9 +611,9 @@ hardline = Line -- -- See 'vcat', 'line', or 'flatAlt' for examples that are related, or make good -- use of it. -group :: Doc ann -> Doc ann +simpleGroup :: Doc ann -> Doc ann -- See note [Group: special flattening] -group x = case changesUponFlattening x of +simpleGroup x = case changesUponFlattening x of Flattened x' -> Union x' x AlreadyFlat -> x NeverFlat -> x diff --git a/prettyprinter/test/Testsuite/Main.hs b/prettyprinter/test/Testsuite/Main.hs index d8492d32..26e96d28 100644 --- a/prettyprinter/test/Testsuite/Main.hs +++ b/prettyprinter/test/Testsuite/Main.hs @@ -90,6 +90,9 @@ tests = testGroup "Tests" , testCase "Line within align" regressionUnboundedGroupedLineWithinAlign ] ] + , testGroup "Group" [ + testProperty "simpleGroup == group" groupLayoutEqualsSimpleGroupLayout + ] ] fusionDoesNotChangeRendering :: FusionDepth -> Property @@ -111,6 +114,17 @@ fusionDoesNotChangeRendering depth , "Fused:" , indent 4 (pretty renderedFused) ] +groupLayoutEqualsSimpleGroupLayout :: Property +groupLayoutEqualsSimpleGroupLayout = forAllShow (arbitrary :: Gen (Doc Int)) (show . diag) (\doc -> + forAll arbitrary (\layouter -> + let grouped = group $ doc + groupedSimple = simpleGroup doc + groupedLayedOut = layout layouter grouped + groupedSimpleLayedOut = layout layouter groupedSimple + in counterexample ("Grouped: " ++ (show . diag $ grouped)) + (counterexample ("Grouped (Simple) " ++ (show . diag $ groupedSimple)) + (groupedLayedOut === groupedSimpleLayedOut)))) + instance Arbitrary ann => Arbitrary (Doc ann) where arbitrary = document shrink = genericShrink -- Possibly not a good idea, may break invariants From 714557dd49b0c6f3ccc26d6623154c6f07800185 Mon Sep 17 00:00:00 2001 From: Jannis Date: Thu, 23 Jan 2020 21:32:42 +0100 Subject: [PATCH 2/8] Totally not a trivial mistake --- prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs b/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs index 17599dd0..aaa73ffe 100755 --- a/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs +++ b/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs @@ -516,8 +516,8 @@ hardline = Line group :: Doc ann -> Doc ann group = \doc -> case doc of - FlatAlt x y -> case changesOnFlattening x of - HasLine -> y + FlatAlt x y -> case changesOnFlattening y of + HasLine -> x NoChange -> Union y x Flat y' -> Union y' x From 1f89ce8dc39c619d355ccf18ed55bdc91922eb8d Mon Sep 17 00:00:00 2001 From: Jannis Date: Thu, 23 Jan 2020 22:04:10 +0100 Subject: [PATCH 3/8] Linter --- prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs | 4 ++-- prettyprinter/test/Testsuite/Main.hs | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs b/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs index aaa73ffe..10ba5b8a 100755 --- a/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs +++ b/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs @@ -561,8 +561,8 @@ changesOnFlattening = \doc -> case doc of (NoChange , Flat b' ) -> Flat (Cat a b') (Flat a' , Flat b' ) -> Flat (Cat a' b') - Annotated ann x -> Annotated ann <$> (changesOnFlattening x) - Nest i x -> Nest i <$> (changesOnFlattening x) + Annotated ann x -> Annotated ann <$> changesOnFlattening x + Nest i x -> Nest i <$> changesOnFlattening x Column f -> Flat (Column (flatten . f)) Nesting f -> Flat (Nesting (flatten . f)) diff --git a/prettyprinter/test/Testsuite/Main.hs b/prettyprinter/test/Testsuite/Main.hs index 26e96d28..50a171d4 100644 --- a/prettyprinter/test/Testsuite/Main.hs +++ b/prettyprinter/test/Testsuite/Main.hs @@ -117,12 +117,12 @@ fusionDoesNotChangeRendering depth groupLayoutEqualsSimpleGroupLayout :: Property groupLayoutEqualsSimpleGroupLayout = forAllShow (arbitrary :: Gen (Doc Int)) (show . diag) (\doc -> forAll arbitrary (\layouter -> - let grouped = group $ doc + let grouped = group doc groupedSimple = simpleGroup doc groupedLayedOut = layout layouter grouped groupedSimpleLayedOut = layout layouter groupedSimple - in counterexample ("Grouped: " ++ (show . diag $ grouped)) - (counterexample ("Grouped (Simple) " ++ (show . diag $ groupedSimple)) + in counterexample ("Grouped: " ++ (show . diag) (grouped)) + (counterexample ("Grouped (Simple) " ++ (show . diag) (groupedSimple)) (groupedLayedOut === groupedSimpleLayedOut)))) instance Arbitrary ann => Arbitrary (Doc ann) where From 8811af291f79fcbe406685c2c71da78d9e21124a Mon Sep 17 00:00:00 2001 From: Jannis Date: Thu, 23 Jan 2020 22:32:42 +0100 Subject: [PATCH 4/8] Update prettyprinter/test/Testsuite/Main.hs Co-Authored-By: Simon Jakobi --- prettyprinter/test/Testsuite/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/prettyprinter/test/Testsuite/Main.hs b/prettyprinter/test/Testsuite/Main.hs index 50a171d4..afad90cf 100644 --- a/prettyprinter/test/Testsuite/Main.hs +++ b/prettyprinter/test/Testsuite/Main.hs @@ -121,7 +121,7 @@ groupLayoutEqualsSimpleGroupLayout = forAllShow (arbitrary :: Gen (Doc Int)) (sh groupedSimple = simpleGroup doc groupedLayedOut = layout layouter grouped groupedSimpleLayedOut = layout layouter groupedSimple - in counterexample ("Grouped: " ++ (show . diag) (grouped)) + in counterexample ("Grouped: " ++ (show . diag) grouped) (counterexample ("Grouped (Simple) " ++ (show . diag) (groupedSimple)) (groupedLayedOut === groupedSimpleLayedOut)))) From ec330bc3cb82f5353bbf19a2a5495ecdf5519189 Mon Sep 17 00:00:00 2001 From: Jannis Date: Thu, 23 Jan 2020 22:32:50 +0100 Subject: [PATCH 5/8] Update prettyprinter/test/Testsuite/Main.hs Co-Authored-By: Simon Jakobi --- prettyprinter/test/Testsuite/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/prettyprinter/test/Testsuite/Main.hs b/prettyprinter/test/Testsuite/Main.hs index afad90cf..11ebfc9b 100644 --- a/prettyprinter/test/Testsuite/Main.hs +++ b/prettyprinter/test/Testsuite/Main.hs @@ -122,7 +122,7 @@ groupLayoutEqualsSimpleGroupLayout = forAllShow (arbitrary :: Gen (Doc Int)) (sh groupedLayedOut = layout layouter grouped groupedSimpleLayedOut = layout layouter groupedSimple in counterexample ("Grouped: " ++ (show . diag) grouped) - (counterexample ("Grouped (Simple) " ++ (show . diag) (groupedSimple)) + (counterexample ("Grouped (Simple) " ++ (show . diag) groupedSimple) (groupedLayedOut === groupedSimpleLayedOut)))) instance Arbitrary ann => Arbitrary (Doc ann) where From fc9d54fb3e01074712e1e62205935cbc987b5623 Mon Sep 17 00:00:00 2001 From: Jannis Date: Wed, 24 Mar 2021 01:24:34 +0100 Subject: [PATCH 6/8] Add note describing the idea and the problem --- prettyprinter/src/Prettyprinter/Internal.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/prettyprinter/src/Prettyprinter/Internal.hs b/prettyprinter/src/Prettyprinter/Internal.hs index 6735d5aa..006c67b7 100755 --- a/prettyprinter/src/Prettyprinter/Internal.hs +++ b/prettyprinter/src/Prettyprinter/Internal.hs @@ -630,6 +630,24 @@ group x = case x of -- See https://github.com/quchen/prettyprinter/issues/22 for the corresponding -- ticket. +-- Note [Group: Optimial placement of Union and loss of information] +-- +-- group will create a 'Union' in place or not at all. A 'Union' for the layout +-- algorithm represents a branch, and if that branch ends up failing, it would +-- be beneficial to keep it as short as possible. Thus group could make an extra +-- effort to push the resulting 'Union' further down or eliminate the branch +-- altogether. The result would be a fewer and smaller branches and thus cheaper +-- failure for the layout algorithm. +-- This approach would not increase the cost of a call to group at all as +-- changesUponFlattening already traverses deep enough already, however, due to +-- an unrelated property of group, placing the resulting 'Union' further down or +-- not at all will harm subsequent calls to group. Currently when calling group +-- with a document that cannot be flattened or an already flat document the Doc +-- will not change at all. This looses information as subsequent calls to group +-- have to come to the same conclusion again and thus retraverse. If we now +-- place the Union (the only evidence that we have done some work) deeper in the +-- tree, subsequent calls will have to retraverse even more nodes. + data FlattenResult a = Flattened a -- ^ @a@ is likely flatter than the input. From a588c97d998175c79bce16576273d058e4dff980 Mon Sep 17 00:00:00 2001 From: Jannis Date: Wed, 24 Mar 2021 01:28:05 +0100 Subject: [PATCH 7/8] Remove old test --- prettyprinter/test/Testsuite/Main.hs | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/prettyprinter/test/Testsuite/Main.hs b/prettyprinter/test/Testsuite/Main.hs index d59641a3..409441ea 100644 --- a/prettyprinter/test/Testsuite/Main.hs +++ b/prettyprinter/test/Testsuite/Main.hs @@ -93,9 +93,6 @@ tests = testGroup "Tests" , testCase "Ribbon width should be computed with `floor` instead of `round` (#157)" computeRibbonWidthWithFloor ] - , testGroup "Group" [ - testProperty "simpleGroup == group" groupLayoutEqualsSimpleGroupLayout - ] ] fusionDoesNotChangeRendering :: FusionDepth -> Property @@ -117,17 +114,6 @@ fusionDoesNotChangeRendering depth , "Fused:" , indent 4 (pretty renderedFused) ] -groupLayoutEqualsSimpleGroupLayout :: Property -groupLayoutEqualsSimpleGroupLayout = forAllShow (arbitrary :: Gen (Doc Int)) (show . diag) (\doc -> - forAll arbitrary (\layouter -> - let grouped = group doc - groupedSimple = simpleGroup doc - groupedLayedOut = layout layouter grouped - groupedSimpleLayedOut = layout layouter groupedSimple - in counterexample ("Grouped: " ++ (show . diag) grouped) - (counterexample ("Grouped (Simple) " ++ (show . diag) groupedSimple) - (groupedLayedOut === groupedSimpleLayedOut)))) - instance Arbitrary ann => Arbitrary (Doc ann) where arbitrary = document shrink = genericShrink -- Possibly not a good idea, may break invariants From 4a1a4c739c32a5cc55c69639beba10ec10faa0c3 Mon Sep 17 00:00:00 2001 From: Jannis Date: Wed, 31 Mar 2021 12:15:06 +0200 Subject: [PATCH 8/8] Reference note in group and adjust text slightly --- prettyprinter/src/Prettyprinter/Internal.hs | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/prettyprinter/src/Prettyprinter/Internal.hs b/prettyprinter/src/Prettyprinter/Internal.hs index 006c67b7..198d6e24 100755 --- a/prettyprinter/src/Prettyprinter/Internal.hs +++ b/prettyprinter/src/Prettyprinter/Internal.hs @@ -605,7 +605,7 @@ hardline = Line -- See 'vcat', 'line', or 'flatAlt' for examples that are related, or make good -- use of it. group :: Doc ann -> Doc ann --- See note [Group: special flattening] +-- See notes [Group: special flattening] and [Group: Optimal placement of Union and loss of information] group x = case x of Union{} -> x FlatAlt a b -> case changesUponFlattening b of @@ -630,7 +630,7 @@ group x = case x of -- See https://github.com/quchen/prettyprinter/issues/22 for the corresponding -- ticket. --- Note [Group: Optimial placement of Union and loss of information] +-- Note [Group: Optimal placement of Union and loss of information] -- -- group will create a 'Union' in place or not at all. A 'Union' for the layout -- algorithm represents a branch, and if that branch ends up failing, it would @@ -638,15 +638,14 @@ group x = case x of -- effort to push the resulting 'Union' further down or eliminate the branch -- altogether. The result would be a fewer and smaller branches and thus cheaper -- failure for the layout algorithm. --- This approach would not increase the cost of a call to group at all as --- changesUponFlattening already traverses deep enough already, however, due to --- an unrelated property of group, placing the resulting 'Union' further down or --- not at all will harm subsequent calls to group. Currently when calling group --- with a document that cannot be flattened or an already flat document the Doc --- will not change at all. This looses information as subsequent calls to group --- have to come to the same conclusion again and thus retraverse. If we now --- place the Union (the only evidence that we have done some work) deeper in the --- tree, subsequent calls will have to retraverse even more nodes. +-- This approach however is flawed, due to an unrelated property of group, +-- placing the resulting 'Union' further down or not at all will harm subsequent +-- calls to group. Currently when calling group with a document that cannot be +-- flattened, or an already flat document, will result in no change at all. This +-- looses information as subsequent calls to group now have to come to the same +-- conclusion again and thus retraverse. If we end up placing a Union (the only +-- evidence that we have done some work) deeper in the tree, subsequent calls +-- will have to retraverse even more nodes. data FlattenResult a = Flattened a