@@ -0,0 +1,67 @@
1+{-# LANGUAGE UndecidableInstances, TypeOperators, DataKinds, TypeFamilies, ScopedTypeVariables#-}
2+
3+{- |
4+
5+Generic implementation of the 'arbitrary' method. Example usage:
6+
7+@
8+data Foo = Foo
9+ { _fooX :: X
10+ , _fooY :: Y
11+ } deriving (Generic)
12+
13+instance Arbitrary Foo where
14+ arbitrary = genericArbitrary
15+ shrink = genericShrink
16+@
17+
18+The generated 'arbitrary' method is equivalent to
19+
20+@Foo <$> arbitrary <*> arbitrary@.
21+
22+-}
23+
24+module Test.QuickCheck.Arbitrary.Generic
25+ ( Arbitrary(..)
26+ , genericArbitrary
27+ , genericShrink
28+ ) where
29+
30+import Control.Applicative
31+import Data.Proxy
32+import GHC.Generics as G
33+import GHC.TypeLits
34+import Test.QuickCheck as QC
35+
36+class GArbitrary a where
37+ gArbitrary :: QC.Gen (a x)
38+
39+instance GArbitrary G.U1 where
40+ gArbitrary = pure G.U1
41+
42+instance Arbitrary c => GArbitrary (G.K1 i c) where
43+ gArbitrary = G.K1 <$> arbitrary
44+
45+instance GArbitrary f => GArbitrary (G.M1 i c f) where
46+ gArbitrary = G.M1 <$> gArbitrary
47+
48+instance (GArbitrary a, GArbitrary b) => GArbitrary (a G.:*: b) where
49+ gArbitrary = liftA2 (G.:*:) gArbitrary gArbitrary
50+
51+-- | Calculates count of constructors encoded by particular ':+:'.
52+-- Internal use only.
53+type family SumLen a :: Nat where
54+ SumLen (a G.:+: b) = (SumLen a) + (SumLen b)
55+ SumLen a = 1
56+
57+instance (GArbitrary a, GArbitrary b, KnownNat (SumLen a), KnownNat (SumLen b)
58+ ) => GArbitrary (a G.:+: b) where
59+ gArbitrary = frequency
60+ [ (lfreq, G.L1 <$> gArbitrary)
61+ , (rfreq, G.R1 <$> gArbitrary) ]
62+ where
63+ lfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen a))
64+ rfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen b))
65+
66+genericArbitrary :: (Generic a, GArbitrary ga, ga ~ G.Rep a) => Gen a
67+genericArbitrary = G.to <$> gArbitrary