Merge pull request #92 from iconnect/adinapoli/investigate-migration-hangs

Add resize to arbitraryOfType and arbitraryOfDecl

Author: adinapoli

src/Data/API/Tools/QuickCheck.hs

@@ -194,16 +194,19 @@ distinguishedElements (x:xs) = ((True, x) : map ((,) False) xs)
 -- | Generate an 'Arbitrary' instance for a union:
 --
 -- > instance Arbitrary Foo where
--- >     arbitrary = oneOf [ fmap Bar arbitrary, fmap Baz arbitrary ]
+-- >     arbitrary = sized $ \ x -> oneOf [ fmap Bar (resize (x `div` 2) arbitrary)
+-- >                                      , fmap Baz (resize (x `div` 2) arbitrary) ]
 
 gen_su_ab :: Tool (APINode, SpecUnion)
 gen_su_ab = mkTool $ \ ts (an, su) -> mkArbitraryInstance ts (nodeRepT an) (bdy an su) (shrinkUnion an su)
   where
     bdy an su | null (suFields su) = nodeConE an
-              | otherwise          = [e| oneof $(listE alts) |]
-      where
-        alts = [ [e| fmap $(nodeAltConE an k) arbitrary |]
-               | (k, _) <- suFields su ]
+              | otherwise          = do
+                  x <- newName "x"
+                  let alts = [ [e| fmap $(nodeAltConE an k) (QC.resize ($(varE x) `div` 2) arbitrary) |]
+                             | (k, _) <- suFields su ]
+                  appE (varE 'QC.sized) $ lamE [varP x] $
+                    varE 'oneof `appE` listE alts
 
     -- For a union, we shrink the individual wrappers.
     shrinkUnion :: APINode -> SpecUnion -> ExpQ

src/Data/API/Value.hs

@@ -367,12 +367,16 @@ arbitrary api = do tn <- QC.elements (Map.keys api)
                    return (TyName tn, v)
 
 -- | Given a schema and a type, generate an arbitrary value of that
--- type.
+-- type.  Uses 'QC.sized' and 'QC.resize' to ensure recursive schemas
+-- terminate by halving the size parameter at each structural
+-- recursion point.
 arbitraryOfType :: NormAPI -> APIType -> QC.Gen Value
-arbitraryOfType api ty0 = case ty0 of
-    TyName  tn -> arbitraryOfDecl api (lookupTyName api tn)
-    TyList  ty -> List  <$> QC.listOf (arbitraryOfType api ty)
-    TyMaybe ty -> Maybe <$> QC.oneof [pure Nothing, Just <$> arbitraryOfType api ty]
+arbitraryOfType api ty0 = QC.sized $ \ size -> case ty0 of
+    TyName  tn -> QC.resize (size `div` 2) $ arbitraryOfDecl api (lookupTyName api tn)
+    TyList  ty -> List  <$> QC.resize (size `div` 2) (QC.listOf (arbitraryOfType api ty))
+    TyMaybe ty -> Maybe <$> if size <= 0
+                             then pure Nothing
+                             else QC.oneof [pure Nothing, Just <$> QC.resize (size `div` 2) (arbitraryOfType api ty)]
     TyJSON     -> JSON  <$> arbitraryJSONValue
     TyBasic bt -> arbitraryOfBasicType bt
 
@@ -388,12 +392,15 @@ arbitraryOfBasicType bt = case bt of
                 <$> QC.arbitrary
 
 arbitraryOfDecl :: NormAPI -> NormTypeDecl -> QC.Gen Value
-arbitraryOfDecl api d = case d of
-    NRecordType nrt -> Record <$> traverse (\ (fn, ty) -> Field fn <$> arbitraryOfType api ty) (Map.toList nrt)
+arbitraryOfDecl api d = QC.sized $ \size ->
+  case d of
+    NRecordType nrt ->
+      let fields = Map.toList nrt
+      in Record <$> traverse (\ (fn, ty) -> Field fn <$> QC.resize (size `div` 2) (arbitraryOfType api ty)) fields
     NUnionType  nut -> do (fn, ty) <- QC.elements (Map.toList nut)
-                          Union fn <$> arbitraryOfType api ty
+                          Union fn <$> QC.resize (size `div` 2) (arbitraryOfType api ty)
     NEnumType   net -> Enum <$> QC.elements (Set.toList net)
-    NTypeSynonym ty -> arbitraryOfType api ty
+    NTypeSynonym ty -> QC.resize (size `div` 2) (arbitraryOfType api ty)
     NNewtype     bt -> arbitraryOfBasicType bt
 
 -- | A reasonably varied generator for JSON 'JS.Value's.