WIP: Implement 'shrink' for Docs by hand

prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs

@@ -1921,6 +1921,24 @@ renderShowS = \sds -> case sds of
     SAnnPush _ x -> renderShowS x
     SAnnPop x    -> renderShowS x
 
+valid :: Doc ann -> Bool
+valid = go False
+  where
+    go mayFail doc = case doc of
+        Fail -> mayFail
+        Empty -> True
+        Char c -> c /= '\n'
+        Text l t -> l == T.length t && l >= 2 && T.all (/= '\n') t
+        Line -> True
+        FlatAlt x y -> go mayFail x && go mayFail y
+        Cat x y -> go mayFail x && go mayFail y
+        Nest _ x -> go mayFail x
+        Union x y -> go True x && go mayFail y
+        Column f -> all (go mayFail) (map f [0..80])
+        WithPageWidth f -> all (go mayFail) (map f (Unbounded : [AvailablePerLine c r | c <- [1..80], r <- [0, 0.1 .. 1]]))
+        Nesting f -> all (go mayFail) (map f [0..80])
+        Annotated _ x -> go mayFail x
+
 
 -- $setup
 --

prettyprinter/test/Testsuite/Main.hs

@@ -17,7 +17,7 @@ import           System.Timeout        (timeout)
 
 import           Data.Text.Prettyprint.Doc
 import           Data.Text.Prettyprint.Doc.Internal
-import           Data.Text.Prettyprint.Doc.Internal.Debug
+import           Data.Text.Prettyprint.Doc.Internal.Debug (diag)
 import           Data.Text.Prettyprint.Doc.Render.Text
 import           Data.Text.Prettyprint.Doc.Render.Util.StackMachine (renderSimplyDecorated)
 
@@ -94,7 +94,7 @@ tests = testGroup "Tests"
 
 fusionDoesNotChangeRendering :: FusionDepth -> Property
 fusionDoesNotChangeRendering depth
-  = forAllShow (arbitrary :: Gen (Doc Int)) (show . diag) (\doc ->
+  = forAllShrinkShow (arbitrary :: Gen (Doc Int)) shrink (show . diag) (\doc ->
     forAll arbitrary (\layouter ->
         let tShow = T.pack . show
             render = renderSimplyDecorated id tShow tShow . layout layouter
@@ -109,11 +109,28 @@ fusionDoesNotChangeRendering depth
             , "Unfused:"
             , indent 4 (pretty rendered)
             , "Fused:"
-            , indent 4 (pretty renderedFused) ]
+            , indent 4 (pretty renderedFused)
+            ]
 
 instance Arbitrary ann => Arbitrary (Doc ann) where
     arbitrary = document
-    shrink = genericShrink -- Possibly not a good idea, may break invariants
+    shrink doc = filter valid $ case doc of
+        Fail            -> [Empty]
+        Empty           -> []
+        Char c          -> Empty : map Char (filter (/= '\n') (shrink c))
+        Text _ t        -> Empty : map pretty (shrink t)
+        Line            -> Empty : [space]
+        FlatAlt x y     -> Empty : noFail x ++ noFail y ++ map (uncurry FlatAlt) (shrink (x, y))
+        Cat x y         -> Empty : noFail x ++ noFail y ++ map (uncurry Cat) (shrink (x, y))
+        Nest i x        -> Empty : noFail x ++ map (flip Nest x) (shrink i)
+        Union x y       -> Empty : noFail x ++ noFail y ++ map (uncurry Union) (shrink (x, y))
+        Column f        -> Empty : noFail (f 0) ++ map Column (shrink f)
+        WithPageWidth f -> Empty : noFail (f defaultPageWidth) ++ map WithPageWidth (shrink f)
+        Nesting f       -> Empty : noFail (f 0) ++ map Nesting (shrink f)
+        Annotated a x   -> Empty : noFail x ++ map (uncurry Annotated) (shrink (a, x))
+      where
+        noFail Fail = []
+        noFail x    = [x]
 
 document :: Arbitrary ann => Gen (Doc ann)
 document = (dampen . frequency)