@@ -52,7 +52,7 @@ newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
54 ( Generic a,
54 ( Generic a,
55− GArbitrary (Rep a) (Rep a),
55+ GArbitrary a (Rep a),
56 RecursivelyShrink (Rep a),
56 RecursivelyShrink (Rep a),
57 GSubterms (Rep a) a
57 GSubterms (Rep a) a
58 ) => Arbitrary (GenericArbitrary a) where
58 ) => Arbitrary (GenericArbitrary a) where
@@ -64,35 +64,45 @@ class Finite a where
64 -- | Generates final element, when size = 0.
64 -- | Generates final element, when size = 0.
65 final :: QC.Gen a
65 final :: QC.Gen a
67−class GArbitrary root a where
67+class GArbitrary self a where
68− gArbitrary :: Proxy root -> QC.Gen (a x)
68+ gArbitrary :: Proxy self -> QC.Gen (a x)
70-- | Unit type instance
70-- | Unit type instance
71−instance GArbitrary root G.U1 where
71+instance GArbitrary self G.U1 where
72 gArbitrary _ = pure G.U1
72 gArbitrary _ = pure G.U1
74-- | Data of the constructor field
74-- | Data of the constructor field
75−instance Arbitrary c => GArbitrary root (Rec0 c) where
75+instance Arbitrary c => GArbitrary self (Rec0 c) where
76 gArbitrary _ = G.K1 <$> arbitrary
76 gArbitrary _ = G.K1 <$> arbitrary
78−-- | Data type meta information
78+-- | Data type with single constructor
80+ ( AllFieldsFinal self f ~ 'True
81+ , GArbitrary self (C1 c f)
79−instance GArbitrary (D1 t f) f => GArbitrary (D1 t f) (D1 t f) where
82+ ) => GArbitrary self (D1 t (C1 c f)) where
80− gArbitrary _ = G.M1 <$> gArbitrary (Proxy @(D1 t f))
83+ gArbitrary _ = G.M1 <$> gArbitrary (Proxy @self)
85+-- | Data type with multiple constructors
87+ ( FinalConstructors self (a :+: b) ~ (x ': y)
88+ , GArbitrary self (a :+: b)
89+ ) => GArbitrary self (D1 t (a :+: b)) where
90+ gArbitrary _ = G.M1 <$> gArbitrary (Proxy @self)
82-- | The constructor meta information
92-- | The constructor meta information
83−instance GArbitrary root f => GArbitrary root (C1 c f) where
93+instance GArbitrary self f => GArbitrary self (C1 c f) where
84− gArbitrary _ = G.M1 <$> scale predNat (gArbitrary (Proxy @root))
94+ gArbitrary _ = G.M1 <$> scale predNat (gArbitrary (Proxy @self))
86 predNat 0 = 0
96 predNat 0 = 0
87 predNat n = pred n
97 predNat n = pred n
89-- | Constructor field meta information
99-- | Constructor field meta information
90−instance GArbitrary root f => GArbitrary root (S1 t f) where
100+instance GArbitrary self f => GArbitrary self (S1 t f) where
91− gArbitrary _ = G.M1 <$> gArbitrary (Proxy @root)
101+ gArbitrary _ = G.M1 <$> gArbitrary (Proxy @self)
93-- | Product
103-- | Product
94−instance (GArbitrary root a, GArbitrary root b) => GArbitrary root (a :*: b) where
104+instance (GArbitrary self a, GArbitrary self b) => GArbitrary self (a :*: b) where
95− gArbitrary _ = liftA2 (:*:) (gArbitrary (Proxy @root)) (gArbitrary (Proxy @root))
105+ gArbitrary _ = liftA2 (:*:) (gArbitrary (Proxy @self)) (gArbitrary (Proxy @self))
97-- | Calculates count of constructors encoded by particular ':+:'.
107-- | Calculates count of constructors encoded by particular ':+:'.
98-- Internal use only.
108-- Internal use only.
@@ -100,28 +110,28 @@ type family SumLen a :: Nat where
100 SumLen (a G.:+: b) = (SumLen a) + (SumLen b)
110 SumLen (a G.:+: b) = (SumLen a) + (SumLen b)
101 SumLen a = 1
111 SumLen a = 1
103−type family FinalConstructors root (a :: * -> *) :: [* -> *] where
113+type family FinalConstructors self (a :: * -> *) :: [* -> *] where
104− FinalConstructors root (a :+: b) =
114+ FinalConstructors self (a :+: b) =
105− FinalConstructors root a :++: FinalConstructors root b
115+ FinalConstructors self a :++: FinalConstructors self b
106− FinalConstructors root (M1 C t f) = If (AllFieldsFinal root f) '[M1 C t f] '[]
116+ FinalConstructors self (M1 C t f) = If (AllFieldsFinal self f) '[M1 C t f] '[]
108−type family AllFieldsFinal root (a :: * -> *) :: Bool where
118+type family AllFieldsFinal self (a :: * -> *) :: Bool where
109− AllFieldsFinal root U1 = 'True
119+ AllFieldsFinal self U1 = 'True
110− AllFieldsFinal root (a :*: b) = AllFieldsFinal root a && AllFieldsFinal root b
120+ AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b
111− AllFieldsFinal root (M1 S t (K1 R typ)) = Not (Equal (Rep typ) root)
121+ AllFieldsFinal self (M1 S t (K1 R self)) = 'False
122+ AllFieldsFinal self (M1 S t (K1 R other)) = 'True
114−instance ( (FinalConstructors root (a :+: b) ~ (x ': y))
115− , GArbitrary root a, GArbitrary root b
125+instance ( GArbitrary self a, GArbitrary self b
116 , KnownNat (SumLen a), KnownNat (SumLen b)
126 , KnownNat (SumLen a), KnownNat (SumLen b)
117− ) => GArbitrary root (a :+: b) where
127+ ) => GArbitrary self (a :+: b) where
118 gArbitrary _ = do
128 gArbitrary _ = do
119 sized $ \s ->
129 sized $ \s ->
120 if s > 1 then usual else final
130 if s > 1 then usual else final
122 usual = frequency
132 usual = frequency
123− [ (lfreq, G.L1 <$> (gArbitrary (Proxy @root)))
133+ [ (lfreq, G.L1 <$> (gArbitrary (Proxy @self)))
124− , (rfreq, G.R1 <$> (gArbitrary (Proxy @root))) ]
134+ , (rfreq, G.R1 <$> (gArbitrary (Proxy @self))) ]
126 lfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen a))
136 lfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen a))
127 rfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen b))
137 rfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen b))
@@ -129,6 +139,6 @@ instance ( (FinalConstructors root (a :+: b) ~ (x ': y))
130genericArbitrary
140genericArbitrary
131 :: forall a ga
141 :: forall a ga
132− . (Generic a, GArbitrary ga ga, ga ~ G.Rep a)
142+ . (Generic a, GArbitrary a ga, ga ~ G.Rep a)
134−genericArbitrary = G.to <$> gArbitrary (Proxy @ga)
144+genericArbitrary = G.to <$> gArbitrary (Proxy @a)