{-# LANGUAGE CPP                  #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE DefaultSignatures    #-}
{-# LANGUAGE DeriveFunctor        #-}
{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE RankNTypes           #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Generate fake values with full constructor coverage
--
-- The idea behind Fake.Cover is that although exhaustive testing is highly
-- exponential, you can cover a large portion of the likely problem cases by
-- exercising all the constructors of a data type and associated fields. This
-- approach only requires a sub-exponential number of cases--far fewer than what
-- you need for the exhaustive approach. The number of test cases needed to
-- ensure that you have full coverage of all the constructors is given by the
-- following relations for product and sum types:
--
-- numCases (a, b) = max (numCases a) (numCases b)
--
-- numCases (Either a b) = numCases a + numCases b
--
-- See the test suite for examples of how many values are generated for
-- different data types.
module Fake.Cover
  ( gcover
  , Coverage(..)
  , Cover(..)
  , bindCover
  , (&>>=)
  ) where

------------------------------------------------------------------------------
import Control.Applicative
import GHC.Generics as G
------------------------------------------------------------------------------
import Fake.Types
------------------------------------------------------------------------------


------------------------------------------------------------------------------
-- | Coverage is a list of values, implemented here with a newtype around a
-- list of fake value generators.  It's @[FGen a]@ instead of @FGen [a]@
-- because we don't want to have to evaluate the 'FGen' monad to work with
-- coverage lists.
newtype Coverage a = Coverage { Coverage a -> [FGen a]
unCoverage :: [FGen a] }
  deriving (a -> Coverage b -> Coverage a
(a -> b) -> Coverage a -> Coverage b
(forall a b. (a -> b) -> Coverage a -> Coverage b)
-> (forall a b. a -> Coverage b -> Coverage a) -> Functor Coverage
forall a b. a -> Coverage b -> Coverage a
forall a b. (a -> b) -> Coverage a -> Coverage b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Coverage b -> Coverage a
$c<$ :: forall a b. a -> Coverage b -> Coverage a
fmap :: (a -> b) -> Coverage a -> Coverage b
$cfmap :: forall a b. (a -> b) -> Coverage a -> Coverage b
Functor)

instance Applicative Coverage where
  pure :: a -> Coverage a
pure = [FGen a] -> Coverage a
forall a. [FGen a] -> Coverage a
Coverage ([FGen a] -> Coverage a) -> (a -> [FGen a]) -> a -> Coverage a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FGen a -> [FGen a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FGen a -> [FGen a]) -> (a -> FGen a) -> a -> [FGen a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FGen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Coverage [FGen (a -> b)]
as <*> :: Coverage (a -> b) -> Coverage a -> Coverage b
<*> Coverage [FGen a]
bs = [FGen b] -> Coverage b
forall a. [FGen a] -> Coverage a
Coverage ([FGen b] -> Coverage b) -> [FGen b] -> Coverage b
forall a b. (a -> b) -> a -> b
$ (FGen (a -> b) -> FGen a -> FGen b)
-> [FGen (a -> b)] -> [FGen a] -> [FGen b]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith FGen (a -> b) -> FGen a -> FGen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
     ([FGen (a -> b)]
as [FGen (a -> b)] -> [FGen (a -> b)] -> [FGen (a -> b)]
forall a. [a] -> [a] -> [a]
++ Int -> [FGen (a -> b)] -> [FGen (a -> b)]
forall a. Int -> [a] -> [a]
take (Int
newlen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
alen) ([FGen (a -> b)] -> [FGen (a -> b)]
forall a. [a] -> [a]
cycle [FGen (a -> b)]
as))
     ([FGen a]
bs [FGen a] -> [FGen a] -> [FGen a]
forall a. [a] -> [a] -> [a]
++ Int -> [FGen a] -> [FGen a]
forall a. Int -> [a] -> [a]
take (Int
newlen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
blen) ([FGen a] -> [FGen a]
forall a. [a] -> [a]
cycle [FGen a]
bs))
   where
    alen :: Int
alen = [FGen (a -> b)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FGen (a -> b)]
as
    blen :: Int
blen = [FGen a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FGen a]
bs
    newlen :: Int
newlen = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
alen Int
blen

------------------------------------------------------------------------------
-- | In some situations you don't have the ability to modify a data structure
-- and need to define different Cover instances for different fields that have
-- the same type.  In these situations, instead of implementing the gcover
-- logic by hand, you could alternatively use gcover to generate stock
-- coverage values and then go back and replace the necessary fields with more
-- appropriate generators.  This bind-like operation provides an easy way to
-- do that.
bindCover :: Coverage a -> (a -> FGen b) -> Coverage b
bindCover :: Coverage a -> (a -> FGen b) -> Coverage b
bindCover (Coverage [FGen a]
gens) a -> FGen b
f = [FGen b] -> Coverage b
forall a. [FGen a] -> Coverage a
Coverage ([FGen b] -> Coverage b) -> [FGen b] -> Coverage b
forall a b. (a -> b) -> a -> b
$ (FGen a -> FGen b) -> [FGen a] -> [FGen b]
forall a b. (a -> b) -> [a] -> [b]
map (FGen a -> (a -> FGen b) -> FGen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> FGen b
f) [FGen a]
gens

------------------------------------------------------------------------------
-- | Convenience infix operator for bindCover.
--
-- @
-- instance Cover Foo where
--   cover = gcover
--     &>>= fooField %%~ (\_ -> fakeFooField)
-- @
(&>>=) :: Coverage a -> (a -> FGen b) -> Coverage b
&>>= :: Coverage a -> (a -> FGen b) -> Coverage b
(&>>=) = Coverage a -> (a -> FGen b) -> Coverage b
forall a b. Coverage a -> (a -> FGen b) -> Coverage b
bindCover
infixl 1 &>>=

instance Alternative Coverage where
  empty :: Coverage a
empty = [FGen a] -> Coverage a
forall a. [FGen a] -> Coverage a
Coverage [FGen a]
forall (f :: * -> *) a. Alternative f => f a
empty
  Coverage [FGen a]
as <|> :: Coverage a -> Coverage a -> Coverage a
<|> Coverage [FGen a]
bs = [FGen a] -> Coverage a
forall a. [FGen a] -> Coverage a
Coverage ([FGen a]
as [FGen a] -> [FGen a] -> [FGen a]
forall a. [a] -> [a] -> [a]
++ [FGen a]
bs)


------------------------------------------------------------------------------
-- | A type class that generates a list of values giving full construcor
-- coverage for data types.  You can write your own instances by hand or you
-- can use the default instance which calls 'gcover' provided your data type
-- has a Generic instance.
class Cover a where
    cover :: Coverage a
    default cover :: (Generic a, GCover ga, ga ~ G.Rep a) => Coverage a
    cover = Coverage a
forall a (ga :: * -> *).
(Generic a, GCover ga, ga ~ Rep a) =>
Coverage a
gcover

instance Cover () where
    cover :: Coverage ()
cover = Coverage ()
forall a (ga :: * -> *).
(Generic a, GCover ga, ga ~ Rep a) =>
Coverage a
gcover

instance Cover a => Cover (Maybe a) where
    cover :: Coverage (Maybe a)
cover = Coverage (Maybe a)
forall a (ga :: * -> *).
(Generic a, GCover ga, ga ~ Rep a) =>
Coverage a
gcover

instance (Cover a, Cover b) => Cover (Either a b) where
    cover :: Coverage (Either a b)
cover = Coverage (Either a b)
forall a (ga :: * -> *).
(Generic a, GCover ga, ga ~ Rep a) =>
Coverage a
gcover

instance (Cover a, Cover b) => Cover (a,b) where
    cover :: Coverage (a, b)
cover = Coverage (a, b)
forall a (ga :: * -> *).
(Generic a, GCover ga, ga ~ Rep a) =>
Coverage a
gcover

instance (Cover a, Cover b, Cover c) => Cover (a,b,c) where
    cover :: Coverage (a, b, c)
cover = Coverage (a, b, c)
forall a (ga :: * -> *).
(Generic a, GCover ga, ga ~ Rep a) =>
Coverage a
gcover

instance (Cover a, Cover b, Cover c, Cover d) => Cover (a,b,c,d) where
    cover :: Coverage (a, b, c, d)
cover = Coverage (a, b, c, d)
forall a (ga :: * -> *).
(Generic a, GCover ga, ga ~ Rep a) =>
Coverage a
gcover

instance (Cover a, Cover b, Cover c, Cover d, Cover e)
      => Cover (a,b,c,d,e) where
    cover :: Coverage (a, b, c, d, e)
cover = Coverage (a, b, c, d, e)
forall a (ga :: * -> *).
(Generic a, GCover ga, ga ~ Rep a) =>
Coverage a
gcover

instance (Cover a, Cover b, Cover c, Cover d, Cover e, Cover f)
      => Cover (a,b,c,d,e,f) where
    cover :: Coverage (a, b, c, d, e, f)
cover = Coverage (a, b, c, d, e, f)
forall a (ga :: * -> *).
(Generic a, GCover ga, ga ~ Rep a) =>
Coverage a
gcover

instance (Cover a, Cover b, Cover c, Cover d, Cover e, Cover f, Cover g)
      => Cover (a,b,c,d,e,f,g) where
    cover :: Coverage (a, b, c, d, e, f, g)
cover = Coverage (a, b, c, d, e, f, g)
forall a (ga :: * -> *).
(Generic a, GCover ga, ga ~ Rep a) =>
Coverage a
gcover
-- GHC only has Generic instances up to 7-tuples


------------------------------------------------------------------------------
-- | A generic function that gives you full constructor coverage for a data
-- type.  Using this function as the 'Cover' instance for a data type avoids
-- the need to explicitly enumerate values that include coverage of all
-- constructors.
gcover :: (Generic a, GCover ga, ga ~ G.Rep a) => Coverage a
gcover :: Coverage a
gcover = [FGen a] -> Coverage a
forall a. [FGen a] -> Coverage a
Coverage ([FGen a] -> Coverage a) -> [FGen a] -> Coverage a
forall a b. (a -> b) -> a -> b
$ (ga Any -> a) -> FGen (ga Any) -> FGen a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ga Any -> a
forall a x. Generic a => Rep a x -> a
G.to (FGen (ga Any) -> FGen a) -> [FGen (ga Any)] -> [FGen a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FGen (ga Any)]
forall (a :: * -> *) x. GCover a => [FGen (a x)]
genericCover


------------------------------------------------------------------------------
-- | Used to implement 'gcover'.
class GCover a where
    genericCover :: [FGen (a x)]

instance GCover G.U1 where
    genericCover :: [FGen (U1 x)]
genericCover = FGen (U1 x) -> [FGen (U1 x)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FGen (U1 x) -> [FGen (U1 x)]) -> FGen (U1 x) -> [FGen (U1 x)]
forall a b. (a -> b) -> a -> b
$ U1 x -> FGen (U1 x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 x
forall k (p :: k). U1 p
G.U1

instance Cover c => GCover (G.K1 i c) where
    genericCover :: [FGen (K1 i c x)]
genericCover = (c -> K1 i c x) -> FGen c -> FGen (K1 i c x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> K1 i c x
forall k i c (p :: k). c -> K1 i c p
G.K1 (FGen c -> FGen (K1 i c x)) -> [FGen c] -> [FGen (K1 i c x)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Coverage c -> [FGen c]
forall a. Coverage a -> [FGen a]
unCoverage Coverage c
forall a. Cover a => Coverage a
cover

instance GCover f => GCover (G.M1 i c f) where
    genericCover :: [FGen (M1 i c f x)]
genericCover = (f x -> M1 i c f x) -> FGen (f x) -> FGen (M1 i c f x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f x -> M1 i c f x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (FGen (f x) -> FGen (M1 i c f x))
-> [FGen (f x)] -> [FGen (M1 i c f x)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FGen (f x)]
forall (a :: * -> *) x. GCover a => [FGen (a x)]
genericCover

instance (GCover a, GCover b) => GCover (a G.:*: b) where
    genericCover :: [FGen ((:*:) a b x)]
genericCover = Coverage ((:*:) a b x) -> [FGen ((:*:) a b x)]
forall a. Coverage a -> [FGen a]
unCoverage (Coverage ((:*:) a b x) -> [FGen ((:*:) a b x)])
-> Coverage ((:*:) a b x) -> [FGen ((:*:) a b x)]
forall a b. (a -> b) -> a -> b
$
      a x -> b x -> (:*:) a b x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(G.:*:) (a x -> b x -> (:*:) a b x)
-> Coverage (a x) -> Coverage (b x -> (:*:) a b x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FGen (a x)] -> Coverage (a x)
forall a. [FGen a] -> Coverage a
Coverage [FGen (a x)]
forall (a :: * -> *) x. GCover a => [FGen (a x)]
genericCover Coverage (b x -> (:*:) a b x)
-> Coverage (b x) -> Coverage ((:*:) a b x)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [FGen (b x)] -> Coverage (b x)
forall a. [FGen a] -> Coverage a
Coverage [FGen (b x)]
forall (a :: * -> *) x. GCover a => [FGen (a x)]
genericCover

instance (GCover a, GCover b) => GCover (a G.:+: b) where
    genericCover :: [FGen ((:+:) a b x)]
genericCover = Coverage ((:+:) a b x) -> [FGen ((:+:) a b x)]
forall a. Coverage a -> [FGen a]
unCoverage (Coverage ((:+:) a b x) -> [FGen ((:+:) a b x)])
-> Coverage ((:+:) a b x) -> [FGen ((:+:) a b x)]
forall a b. (a -> b) -> a -> b
$
      (a x -> (:+:) a b x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
G.L1 (a x -> (:+:) a b x) -> Coverage (a x) -> Coverage ((:+:) a b x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FGen (a x)] -> Coverage (a x)
forall a. [FGen a] -> Coverage a
Coverage [FGen (a x)]
forall (a :: * -> *) x. GCover a => [FGen (a x)]
genericCover) Coverage ((:+:) a b x)
-> Coverage ((:+:) a b x) -> Coverage ((:+:) a b x)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (b x -> (:+:) a b x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
G.R1 (b x -> (:+:) a b x) -> Coverage (b x) -> Coverage ((:+:) a b x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FGen (b x)] -> Coverage (b x)
forall a. [FGen a] -> Coverage a
Coverage [FGen (b x)]
forall (a :: * -> *) x. GCover a => [FGen (a x)]
genericCover)