diff --git a/htest/Test/Ganeti/TestHelper.hs b/htest/Test/Ganeti/TestHelper.hs index 8a4fc255feb55e935cae2ba4f5580cf016a060e9..17a1f9b465b8ffc48a662574cdee9edab730e4e9 100644 --- a/htest/Test/Ganeti/TestHelper.hs +++ b/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