Sized QuickCheck properties to avoid test blowups

Text/PrettyPrint/Tests.hs

@@ -12,35 +12,53 @@ instance Arbitrary Alignment where
                        ]
 
 instance Arbitrary Box where
-  arbitrary = do
-    (NonNegative r) <- arbitrary
-    (NonNegative c) <- arbitrary
-    liftM (Box r c) arbitrary
+  arbitrary = sized arbBox
+
+-- A sized generator for boxes. The larger the parameter is, the larger a
+-- generated Box is likely to be. This is necessary in order to avoid
+-- the tests getting stuck trying to generate ridiculously huge Box values.
+arbBox :: Int -> Gen Box
+arbBox n = do
+  NonNegative r <- arbitrary
+  NonNegative c <- arbitrary
+  liftM (Box r c) (arbContent n)
 
 instance Arbitrary Content where
-  arbitrary = oneof [ return Blank
-                    , liftM Text arbitrary
-                    , liftM Row arbitrary
-                    , liftM Col arbitrary
-                    , liftM3 SubBox arbitrary arbitrary arbitrary
-                    ]
+  arbitrary = sized arbContent
+
+-- A sized generator for Content values. The larger the parameter is, the
+-- larger a generated Content is likely to be. This is necessary in order to
+-- avoid the tests getting stuck trying to generate ridiculously huge Content
+-- values. To this end, we halve the size parameter for child boxes or lists of
+-- child boxes.
+--
+-- See also section 3.2 of http://www.cs.tufts.edu/%7Enr/cs257/archive/john-hughes/quick.pdf
+arbContent :: Int -> Gen Content
+arbContent 0 = return Blank
+arbContent n =
+  oneof [ return Blank
+        , liftM Text arbitrary
+        , liftM Row (halveSize (listOf box))
+        , liftM Col (halveSize (listOf box))
+        , liftM3 SubBox arbitrary arbitrary (halveSize box)
+        ]
+  where
+  halveSize = scale (`quot` 2)
+  box = arbBox n
 
 -- extensional equivalence for Boxes
 b1 ==== b2 = render b1 == render b2
 
 prop_render_text s = render (text s) == (s ++ "\n")
 
-{-
-TODO: Find a way to enable these tests without time and space
-explosion.
-
---prop_empty_right_id b = b <> nullBox ==== b
---prop_empty_left_id b  = nullBox <> b ==== b
---prop_empty_top_id b   = nullBox // b ==== b
---prop_empty_bot_id b   = b // nullBox ==== b
--}
+prop_empty_right_id b = b <> nullBox ==== b
+prop_empty_left_id b  = nullBox <> b ==== b
+prop_empty_top_id b   = nullBox // b ==== b
+prop_empty_bot_id b   = b // nullBox ==== b
 
-main = quickCheckResult prop_render_text >>= \result ->
-          case result of
-            Success{} -> exitSuccess
-            _ -> exitFailure
+main = do
+  quickCheck prop_render_text
+  quickCheck prop_empty_right_id
+  quickCheck prop_empty_left_id
+  quickCheck prop_empty_top_id
+  quickCheck prop_empty_bot_id