mirror of
https://github.com/Lysxia/generic-random.git
synced 2024-09-11 06:35:24 +03:00
Allow custom generator lists to not be terminated by ":+ ()"
This commit is contained in:
parent
5de3160fa6
commit
aedd4474a1
@ -33,8 +33,7 @@ instance Arbitrary R where
|
||||
gens =
|
||||
(FieldGen (pack . filter isAlphaNum <$> scale (* 5) arbitrary)
|
||||
:: FieldGen "id_" Text) :+
|
||||
(pack . filter (/= '\NUL') <$> arbitrary) :+
|
||||
()
|
||||
(pack . filter (/= '\NUL') <$> arbitrary)
|
||||
|
||||
shrink = genericShrink
|
||||
|
||||
|
@ -495,10 +495,10 @@ instance GAProduct' c i opts U1 where
|
||||
|
||||
instance
|
||||
( HasGenerators opts
|
||||
, ArbitraryOr gs gs '(c, i, Name d) a
|
||||
, ArbitraryOr gs () gs '(c, i, Name d) a
|
||||
, gs ~ GeneratorsOf opts )
|
||||
=> GAProduct' c i opts (S1 d (K1 _k a)) where
|
||||
gaProduct' _ opts = fmap (M1 . K1) (arbitraryOr sel gs gs)
|
||||
gaProduct' _ opts = fmap (M1 . K1) (arbitraryOr sel gs () gs)
|
||||
where
|
||||
sel = Proxy :: Proxy '(c, i, Name d)
|
||||
gs = generators opts
|
||||
@ -516,31 +516,65 @@ type family Arity f :: Nat where
|
||||
Arity (f :*: g) = Arity f + Arity g
|
||||
Arity (M1 _i _c _f) = 1
|
||||
|
||||
-- | Given a list of custom generators @gs@, find one that applies, or use
|
||||
-- @Arbitrary a@ by default.
|
||||
--
|
||||
-- @g@ and @gs@ follow this little state machine:
|
||||
--
|
||||
-- > g, gs | result
|
||||
-- > ---------------------+-----------------------------
|
||||
-- > (), () | END
|
||||
-- > (), g :+ gs | g, gs
|
||||
-- > g :+ h, gs | g, h :+ gs
|
||||
-- > Gen a, gs | END if matching, else (), gs
|
||||
-- > FieldGen a, gs | idem
|
||||
-- > ConstrGen a, gs | idem
|
||||
-- > Gen1 a, gs | idem
|
||||
-- > Gen1_ a, gs | idem
|
||||
class ArbitraryOr (fullGenList :: Type) (g :: Type) (gs :: Type)
|
||||
(sel :: (Maybe Symbol, Nat, Maybe Symbol)) a where
|
||||
arbitraryOr :: proxy sel -> fullGenList -> g -> gs -> Gen a
|
||||
|
||||
class ArbitraryOr (fullGenList :: Type) (genList :: Type) (sel :: (Maybe Symbol, Nat, Maybe Symbol)) a where
|
||||
arbitraryOr :: proxy sel -> fullGenList -> genList -> Gen a
|
||||
|
||||
instance {-# INCOHERENT #-} ArbitraryOr fg (Gen a :+ g) sel a where
|
||||
arbitraryOr _ _ (gen :+ _) = gen
|
||||
-- | All candidates have been exhausted
|
||||
instance Arbitrary a => ArbitraryOr fg () () sel a where
|
||||
arbitraryOr _ _ _ _ = arbitrary
|
||||
{-# INLINE arbitraryOr #-}
|
||||
|
||||
instance {-# OVERLAPPABLE #-} ArbitraryOr fg g sel a => ArbitraryOr fg (b :+ g) sel a where
|
||||
arbitraryOr sel fg (_ :+ gens) = arbitraryOr sel fg gens
|
||||
-- | Examine the next candidate
|
||||
instance ArbitraryOr fg b g sel a => ArbitraryOr fg () (b :+ g) sel a where
|
||||
arbitraryOr sel fg () (b :+ gens) = arbitraryOr sel fg b gens
|
||||
{-# INLINE arbitraryOr #-}
|
||||
|
||||
instance Arbitrary a => ArbitraryOr fg () sel a where
|
||||
arbitraryOr _ _ _ = arbitrary
|
||||
-- | Examine the last candidate (@g@ is not of the form @_ :+ _@)
|
||||
instance {-# OVERLAPS #-} ArbitraryOr fg g () sel a => ArbitraryOr fg () g sel a where
|
||||
arbitraryOr sel fg () g = arbitraryOr sel fg g ()
|
||||
|
||||
-- | This can happen if the generators form a tree rather than a list, for whatever reason.
|
||||
instance ArbitraryOr fg g (h :+ gs) sel a => ArbitraryOr fg (g :+ h) gs sel a where
|
||||
arbitraryOr sel fg (g :+ h) gs = arbitraryOr sel fg g (h :+ gs)
|
||||
|
||||
-- | None of the INCOHERENT instances match, discard the candidate @g@ and look
|
||||
-- at the rest of the list @gs@.
|
||||
instance {-# OVERLAPPABLE #-} ArbitraryOr fg () gs sel a => ArbitraryOr fg g gs sel a where
|
||||
arbitraryOr sel fg _ = arbitraryOr sel fg ()
|
||||
|
||||
-- | Matching custom generator for @a@.
|
||||
instance {-# INCOHERENT #-} ArbitraryOr fg (Gen a) g sel a where
|
||||
arbitraryOr _ _ gen _ = gen
|
||||
{-# INLINE arbitraryOr #-}
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
instance {-# INCOHERENT #-} (a ~ a') => ArbitraryOr fg (FieldGen n a :+ g) '(con, i, 'Just n) a' where
|
||||
arbitraryOr _ _ (FieldGen gen :+ _) = gen
|
||||
-- | Matching custom generator for field @s@.
|
||||
instance {-# INCOHERENT #-} (a ~ a') => ArbitraryOr fg (FieldGen s a) g '(con, i, 'Just s) a' where
|
||||
arbitraryOr _ _ (FieldGen gen) _ = gen
|
||||
{-# INLINE arbitraryOr #-}
|
||||
|
||||
instance {-# INCOHERENT #-} (a ~ a') => ArbitraryOr fg (ConstrGen c i a :+ g) '( 'Just c, i, s) a' where
|
||||
arbitraryOr _ _ (ConstrGen gen :+ _) = gen
|
||||
-- | Matching custom generator for @i@-th field of constructor @c@.
|
||||
instance {-# INCOHERENT #-} (a ~ a') => ArbitraryOr fg (ConstrGen c i a) g '( 'Just c, i, s) a' where
|
||||
arbitraryOr _ _ (ConstrGen gen) _ = gen
|
||||
{-# INLINE arbitraryOr #-}
|
||||
|
||||
-- | Get the name contained in a 'Meta' tag.
|
||||
type family Name (d :: Meta) :: Maybe Symbol
|
||||
type instance Name ('MetaSel mn su ss ds) = mn
|
||||
type instance Name ('MetaCons n _f _s) = 'Just n
|
||||
@ -548,12 +582,15 @@ type instance Name ('MetaCons n _f _s) = 'Just n
|
||||
type Name d = (Nothing :: Maybe Symbol)
|
||||
#endif
|
||||
|
||||
instance {-# INCOHERENT #-} ArbitraryOr fg (Gen1_ f :+ g) sel (f a) where
|
||||
arbitraryOr _ _ (Gen1_ gen :+ _) = gen
|
||||
-- | Matching custom generator for non-container @f@
|
||||
instance {-# INCOHERENT #-} ArbitraryOr fg (Gen1_ f) g sel (f a) where
|
||||
arbitraryOr _ _ (Gen1_ gen) _ = gen
|
||||
|
||||
instance {-# INCOHERENT #-} ArbitraryOr fg fg '( 'Nothing, 0, 'Nothing) a
|
||||
=> ArbitraryOr fg (Gen1 f :+ g) sel (f a) where
|
||||
arbitraryOr _ fg (Gen1 gen :+ _) = gen (arbitraryOr noSel fg fg)
|
||||
-- | Matching custom generator for container @f@. Start the search for containee @a@,
|
||||
-- discarding field information.
|
||||
instance {-# INCOHERENT #-} ArbitraryOr fg () fg '( 'Nothing, 0, 'Nothing) a
|
||||
=> ArbitraryOr fg (Gen1 f) g sel (f a) where
|
||||
arbitraryOr _ fg (Gen1 gen) _ = gen (arbitraryOr noSel fg () fg)
|
||||
where noSel = Proxy :: Proxy '( 'Nothing, 0, 'Nothing)
|
||||
|
||||
newtype Weighted a = Weighted (Maybe (Int -> Gen a, Int))
|
||||
|
@ -201,15 +201,13 @@
|
||||
-- are big or change often).
|
||||
--
|
||||
-- Using generic-random, we can declare a (heterogeneous) list of generators to
|
||||
-- be used instead of 'Test.QuickCheck.arbitrary' when generating certain fields (remember to
|
||||
-- end lists with @()@).
|
||||
-- be used instead of 'Test.QuickCheck.arbitrary' when generating certain fields.
|
||||
--
|
||||
-- @
|
||||
-- customGens :: 'FieldGen' "userId" Int ':+' 'Test.QuickCheck.Gen' String ':+' ()
|
||||
-- customGens :: 'FieldGen' "userId" Int ':+' 'Test.QuickCheck.Gen' String
|
||||
-- customGens =
|
||||
-- 'FieldGen' ('Test.QuickCheck.getNonNegative' '<$>' arbitrary) ':+'
|
||||
-- 'Test.QuickCheck.listOf' ('Test.QuickCheck.elements' (filter isAlphaNum [minBound .. maxBound])) ':+'
|
||||
-- ()
|
||||
-- 'Test.QuickCheck.listOf' ('Test.QuickCheck.elements' (filter isAlphaNum [minBound .. maxBound]))
|
||||
-- @
|
||||
--
|
||||
-- Now we use the 'genericArbitraryG' combinator and other @G@-suffixed
|
||||
@ -253,8 +251,8 @@
|
||||
-- where
|
||||
-- -- Generator for the left field (i.e., at index 0) of constructor Node,
|
||||
-- -- which must have type (Tree a).
|
||||
-- customGens :: 'ConstrGen' \"Node\" 0 (Tree a) ':+' ()
|
||||
-- customGens = 'ConstrGen' (Leaf '<$>' arbitrary) ':+' ()
|
||||
-- customGens :: 'ConstrGen' \"Node\" 0 (Tree a)
|
||||
-- customGens = 'ConstrGen' (Leaf '<$>' arbitrary)
|
||||
-- @
|
||||
--
|
||||
-- That instance is equivalent to the following:
|
||||
|
@ -46,7 +46,7 @@ eval name g = do
|
||||
data Tree2 = Leaf2 Int | Node2 Tree2 Tree2 deriving (Generic, Show)
|
||||
|
||||
instance Arbitrary Tree2 where
|
||||
arbitrary = genericArbitraryUG ((ConstrGen (Leaf2 <$> arbitrary) :: ConstrGen "Node2" 1 Tree2) :+ ())
|
||||
arbitrary = genericArbitraryUG ((ConstrGen (Leaf2 <$> arbitrary) :: ConstrGen "Node2" 1 Tree2))
|
||||
|
||||
isLeftBiased :: Tree2 -> Bool
|
||||
isLeftBiased (Leaf2 _) = True
|
||||
|
Loading…
Reference in New Issue
Block a user