Introduce a helper for simple Arbitrary instances

After getting really annoyed at yet another "<*> arbitrary", I thought
that we should be able to automate this, at least for types which are
simple enough and have already all the "prerequisites".

Hence the new genArbitrary function and its helpers, which can:

- build an arbitrary for Bounded types, using the regular "elements
  [minBound..maxBound]" (20 manually defined cases right now)
- build an arbitrary instance for single-constructor data types,
  e.g. "data A = A x y z", using a simple "arbitrary = pure A <*>
  arbitrary <*> arbitrary <*> arbitrary"
- build an arbitrary instance for multi-constructor data types, using
  "arbitrary = oneof [<arbitrary for each individual construct, per
  the previous>]"

Both normal and record-based constructors are supported.

It can also build arbitrary instances for new types and type synonyms,
although for these last two I'm not so confident on the soundness of
the instances.

Note that this helper won't work for types which are not well behaved;
for example, Node has the name as String not as FQDN, so our manually
written arbitrary instance has just a few overrides as getFQDN instead
of arbitrary, so we can't automate this particular type yet; this only
means we get another push to use proper types, instead of primitive
ones, for fields which have any kinds of restrictions ("what's good
for arbitrary is good for regular code" too).

Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: René Nussbaumer <rn@google.com>

htest/Test/Ganeti/TestHelper.hs

@@ -27,8 +27,10 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 
 module Test.Ganeti.TestHelper
   ( testSuite
+  , genArbitrary
   ) where
 
+import Control.Applicative
 import Data.List (stripPrefix, isPrefixOf)
 import Data.Maybe (fromMaybe)
 import Test.Framework
@@ -84,3 +86,49 @@ testSuite tsname tdef = do
          , ValD (VarP fullname) (NormalB (TupE [LitE (StringL tsname),
                                                 ListE tests])) []
          ]
+
+-- | Builds an arbitrary value for a given constructor. This doesn't
+-- use the actual types of the fields, since we expect arbitrary
+-- instances for all of the types anyway, we only care about the
+-- number of fields.
+mkConsArbitrary :: (Name, [a]) -> Exp
+mkConsArbitrary (name, types) =
+  let infix_arb a = InfixE (Just a) (VarE '(<*>)) (Just (VarE 'arbitrary))
+      constr = AppE (VarE 'pure) (ConE name)
+  in foldl (\a _ -> infix_arb a) (constr) types
+
+-- | Extracts the name and the types from a constructor.
+conInfo :: Con -> (Name, [Type])
+conInfo (NormalC name t)     = (name, map snd t)
+conInfo (RecC    name t)     = (name, map (\(_, _, x) -> x) t)
+conInfo (InfixC t1 name t2)  = (name, [snd t1, snd t2])
+conInfo (ForallC _ _ subcon) = conInfo subcon
+
+-- | Builds an arbitrary instance for a regular data type (i.e. not Bounded).
+mkRegularArbitrary :: Name -> [Con] -> Q [Dec]
+mkRegularArbitrary name cons = do
+  expr <- case cons of
+            [] -> fail $ "Can't make Arbitrary instance for an empty data type"
+            [x] -> return $ mkConsArbitrary (conInfo x)
+            xs -> appE (varE 'oneof) $
+                  listE (map (return . mkConsArbitrary . conInfo) xs)
+  return [InstanceD [] (AppT (ConT ''Arbitrary) (ConT name))
+          [ValD (VarP 'arbitrary) (NormalB expr) []]]
+
+-- | Builds a default Arbitrary instance for a type. This requires
+-- that all members are of types that already have Arbitrary
+-- instances, and that the arbitrary instances are well behaved
+-- (w.r.t. recursive data structures, or similar concerns). In that
+-- sense, this is not appropriate for all data types, just those that
+-- are simple but very repetitive or have many simple fields.
+genArbitrary :: Name -> Q [Dec]
+genArbitrary name = do
+  r <- reify name
+  case r of
+    TyConI (DataD _ _ _ cons _) ->
+      mkRegularArbitrary name cons
+    TyConI (NewtypeD _ _ _ con _) ->
+      mkRegularArbitrary name [con]
+    TyConI (TySynD _ _ (ConT tn)) -> genArbitrary tn
+    _ -> fail $ "Invalid type in call to genArbitrary for " ++ show name
+         ++ ", type " ++ show r