{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TemplateHaskell            #-}

module Data.API.Tools.QuickCheck
    ( quickCheckTool
    ) where

import           Data.API.TH
import           Data.API.Time ()
import           Data.API.Tools.Combinators
import           Data.API.Tools.Datatypes
import           Data.API.Types

import           Control.Applicative
import           Data.Monoid
import           Data.Time
import           Language.Haskell.TH
import           Test.QuickCheck                as QC
import           Prelude


-- | Tool to generate 'Arbitrary' instances for generated types.
quickCheckTool :: APITool
quickCheckTool :: APITool
quickCheckTool = Tool APINode -> APITool
apiNodeTool (Tool APINode -> APITool) -> Tool APINode -> APITool
forall a b. (a -> b) -> a -> b
$ Tool (APINode, SpecNewtype)
-> Tool (APINode, SpecRecord)
-> Tool (APINode, SpecUnion)
-> Tool (APINode, SpecEnum)
-> Tool (APINode, APIType)
-> Tool APINode
apiSpecTool Tool (APINode, SpecNewtype)
gen_sn_ab Tool (APINode, SpecRecord)
gen_sr_ab Tool (APINode, SpecUnion)
gen_su_ab Tool (APINode, SpecEnum)
gen_se_ab Tool (APINode, APIType)
forall a. Monoid a => a
mempty


-- | Generate an 'Arbitrary' instance for a newtype that respects its
-- filter.  We don't try to generate arbitrary data matching a regular
-- expression, however: instances must be supplied manually.  When
-- generating arbitrary integers, use 'arbitraryBoundedIntegral'
-- rather than 'arbitrary' (the latter tends to generate non-unique
-- values).
gen_sn_ab :: Tool (APINode, SpecNewtype)
gen_sn_ab :: Tool (APINode, SpecNewtype)
gen_sn_ab = (ToolSettings -> (APINode, SpecNewtype) -> Q [Dec])
-> Tool (APINode, SpecNewtype)
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> (APINode, SpecNewtype) -> Q [Dec])
 -> Tool (APINode, SpecNewtype))
-> (ToolSettings -> (APINode, SpecNewtype) -> Q [Dec])
-> Tool (APINode, SpecNewtype)
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecNewtype
sn) -> case SpecNewtype -> Maybe Filter
snFilter SpecNewtype
sn of
    Maybe Filter
Nothing | SpecNewtype -> BasicType
snType SpecNewtype
sn BasicType -> BasicType -> Bool
forall a. Eq a => a -> a -> Bool
== BasicType
BTint    -> ToolSettings -> APINode -> SpecNewtype -> Q Exp -> Q [Dec]
mk_instance ToolSettings
ts APINode
an SpecNewtype
sn [e| QC.arbitraryBoundedIntegral |]
            | Bool
otherwise             -> ToolSettings -> APINode -> SpecNewtype -> Q Exp -> Q [Dec]
mk_instance ToolSettings
ts APINode
an SpecNewtype
sn [e| arbitrary |]
    Just (FtrIntg IntRange
ir)               -> ToolSettings -> APINode -> SpecNewtype -> Q Exp -> Q [Dec]
mk_instance ToolSettings
ts APINode
an SpecNewtype
sn [e| arbitraryIntRange ir |]
    Just (FtrUTC UTCRange
ur)                -> ToolSettings -> APINode -> SpecNewtype -> Q Exp -> Q [Dec]
mk_instance ToolSettings
ts APINode
an SpecNewtype
sn [e| arbitraryUTCRange ur |]
    Just (FtrStrg RegEx
_)                -> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  where
    mk_instance :: ToolSettings -> APINode -> SpecNewtype -> Q Exp -> Q [Dec]
mk_instance ToolSettings
ts APINode
an SpecNewtype
sn Q Exp
arb = ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''Arbitrary [APINode -> TypeQ
nodeRepT APINode
an]
                                  [Name -> Q Exp -> DecQ
simpleD 'arbitrary [e| fmap $(ToolSettings -> APINode -> SpecNewtype -> Q Exp
nodeNewtypeConE ToolSettings
ts APINode
an SpecNewtype
sn) $Q Exp
arb |]]


-- | Generate an 'Arbitrary' instance for a record:
--
-- > instance Arbitrary Foo where
-- >     arbitrary = sized $ \ x -> Foo <$> resize (x `div` 2) arbitrary <*> ... <*> resize (x `div` 2) arbitrary

gen_sr_ab :: Tool (APINode, SpecRecord)
gen_sr_ab :: Tool (APINode, SpecRecord)
gen_sr_ab = (ToolSettings -> (APINode, SpecRecord) -> Q [Dec])
-> Tool (APINode, SpecRecord)
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> (APINode, SpecRecord) -> Q [Dec])
 -> Tool (APINode, SpecRecord))
-> (ToolSettings -> (APINode, SpecRecord) -> Q [Dec])
-> Tool (APINode, SpecRecord)
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecRecord
sr) -> ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''QC.Arbitrary [APINode -> TypeQ
nodeRepT APINode
an]
                                          [Name -> Q Exp -> DecQ
simpleD 'arbitrary (APINode -> SpecRecord -> Q Exp
bdy APINode
an SpecRecord
sr)]
  where
    -- Reduce size of fields to avoid generating massive test data
    -- by giving an arbitrary implementation like this:
    --   sized (\ x -> JobSpecId <$> resize (x `div` 2) arbitrary <*> ...)
    bdy :: APINode -> SpecRecord -> Q Exp
bdy APINode
an SpecRecord
sr = do Name
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
                   Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'QC.sized) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
                     Q Exp -> [Q Exp] -> Q Exp
applicativeE (APINode -> Q Exp
nodeConE APINode
an) ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$
                     Int -> Q Exp -> [Q Exp]
forall a. Int -> a -> [a]
replicate ([(FieldName, FieldType)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(FieldName, FieldType)] -> Int)
-> [(FieldName, FieldType)] -> Int
forall a b. (a -> b) -> a -> b
$ SpecRecord -> [(FieldName, FieldType)]
srFields SpecRecord
sr) (Q Exp -> [Q Exp]) -> Q Exp -> [Q Exp]
forall a b. (a -> b) -> a -> b
$
                     [e| QC.resize ($(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) `div` 2) arbitrary |]


-- | Generate an 'Arbitrary' instance for a union:
--
-- > instance Arbitrary Foo where
-- >     arbitrary = oneOf [ fmap Bar arbitrary, fmap Baz arbitrary ]

gen_su_ab :: Tool (APINode, SpecUnion)
gen_su_ab :: Tool (APINode, SpecUnion)
gen_su_ab = (ToolSettings -> (APINode, SpecUnion) -> Q [Dec])
-> Tool (APINode, SpecUnion)
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> (APINode, SpecUnion) -> Q [Dec])
 -> Tool (APINode, SpecUnion))
-> (ToolSettings -> (APINode, SpecUnion) -> Q [Dec])
-> Tool (APINode, SpecUnion)
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecUnion
su) -> ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''QC.Arbitrary [APINode -> TypeQ
nodeRepT APINode
an]
                                          [Name -> Q Exp -> DecQ
simpleD 'arbitrary (APINode -> SpecUnion -> Q Exp
bdy APINode
an SpecUnion
su)]
  where
    bdy :: APINode -> SpecUnion -> Q Exp
bdy APINode
an SpecUnion
su | [(FieldName, (APIType, String))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (SpecUnion -> [(FieldName, (APIType, String))]
suFields SpecUnion
su) = APINode -> Q Exp
nodeConE APINode
an
              | Bool
otherwise          = [e| oneof $([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [Q Exp]
alts) |]
      where
        alts :: [Q Exp]
alts = [ [e| fmap $(APINode -> FieldName -> Q Exp
nodeAltConE APINode
an FieldName
k) arbitrary |]
               | (FieldName
k, (APIType, String)
_) <- SpecUnion -> [(FieldName, (APIType, String))]
suFields SpecUnion
su ]


-- | Generate an 'Arbitrary' instance for an enumeration:
--
-- > instance Arbitrary Foo where
-- >     arbitrary = elements [Bar, Baz]

gen_se_ab :: Tool (APINode, SpecEnum)
gen_se_ab :: Tool (APINode, SpecEnum)
gen_se_ab = (ToolSettings -> (APINode, SpecEnum) -> Q [Dec])
-> Tool (APINode, SpecEnum)
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> (APINode, SpecEnum) -> Q [Dec])
 -> Tool (APINode, SpecEnum))
-> (ToolSettings -> (APINode, SpecEnum) -> Q [Dec])
-> Tool (APINode, SpecEnum)
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecEnum
se) -> ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''QC.Arbitrary [APINode -> TypeQ
nodeRepT APINode
an]
                                          [Name -> Q Exp -> DecQ
simpleD 'arbitrary (APINode -> SpecEnum -> Q Exp
bdy APINode
an SpecEnum
se)]
  where
    bdy :: APINode -> SpecEnum -> Q Exp
bdy APINode
an SpecEnum
se | [Q Exp] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Q Exp]
ks   = APINode -> Q Exp
nodeConE APINode
an
              | Bool
otherwise = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'elements Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [Q Exp]
ks
      where
        ks :: [Q Exp]
ks = ((FieldName, String) -> Q Exp) -> [(FieldName, String)] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (APINode -> FieldName -> Q Exp
nodeAltConE APINode
an (FieldName -> Q Exp)
-> ((FieldName, String) -> FieldName)
-> (FieldName, String)
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldName, String) -> FieldName
forall a b. (a, b) -> a
fst) ([(FieldName, String)] -> [Q Exp])
-> [(FieldName, String)] -> [Q Exp]
forall a b. (a -> b) -> a -> b
$ SpecEnum -> [(FieldName, String)]
seAlts SpecEnum
se


-- | Generate an arbitrary 'Int' in a given range.
arbitraryIntRange :: IntRange -> Gen Int
arbitraryIntRange :: IntRange -> Gen Int
arbitraryIntRange (IntRange (Just Int
lo) Maybe Int
Nothing  ) = (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
lo, Int
forall a. Bounded a => a
maxBound)
arbitraryIntRange (IntRange Maybe Int
Nothing   (Just Int
hi)) = (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
forall a. Bounded a => a
minBound, Int
hi)
arbitraryIntRange (IntRange (Just Int
lo) (Just Int
hi)) = (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
lo, Int
hi)
arbitraryIntRange (IntRange Maybe Int
Nothing   Maybe Int
Nothing  ) = Gen Int
forall a. Arbitrary a => Gen a
QC.arbitrary

-- | Generate an arbitrary 'UTCTime' in a given range.
-- TODO: we might want to generate a broader range of sample times,
-- rather than just the extrema.
arbitraryUTCRange :: UTCRange -> Gen UTCTime
arbitraryUTCRange :: UTCRange -> Gen UTCTime
arbitraryUTCRange (UTCRange (Just UTCTime
lo) Maybe UTCTime
Nothing  ) = UTCTime -> Gen UTCTime
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTCTime
lo
arbitraryUTCRange (UTCRange Maybe UTCTime
Nothing   (Just UTCTime
hi)) = UTCTime -> Gen UTCTime
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTCTime
hi
arbitraryUTCRange (UTCRange (Just UTCTime
lo) (Just UTCTime
hi)) = [UTCTime] -> Gen UTCTime
forall a. HasCallStack => [a] -> Gen a
QC.elements [UTCTime
lo, UTCTime
hi]
arbitraryUTCRange (UTCRange Maybe UTCTime
Nothing   Maybe UTCTime
Nothing  ) = Gen UTCTime
forall a. Arbitrary a => Gen a
QC.arbitrary