{-# 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 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 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 = forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool 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 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
_)                -> 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 $(nodeNewtypeConE ts an sn) $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 = forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool 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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
                   forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'QC.sized) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x] forall a b. (a -> b) -> a -> b
$
                     Q Exp -> [Q Exp] -> Q Exp
applicativeE (APINode -> Q Exp
nodeConE APINode
an) forall a b. (a -> b) -> a -> b
$
                     forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ SpecRecord -> [(FieldName, FieldType)]
srFields SpecRecord
sr) forall a b. (a -> b) -> a -> b
$
                     [e| QC.resize ($(varE 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 = forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool 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 | 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 $(listE alts) |]
      where
        alts :: [Q Exp]
alts = [ [e| fmap $(nodeAltConE an 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 = forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool 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 | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Q Exp]
ks   = APINode -> Q Exp
nodeConE APINode
an
              | Bool
otherwise = forall (m :: * -> *). Quote m => Name -> m Exp
varE 'elements forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [Q Exp]
ks
      where
        ks :: [Q Exp]
ks = forall a b. (a -> b) -> [a] -> [b]
map (APINode -> FieldName -> Q Exp
nodeAltConE APINode
an forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) 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  ) = forall a. Random a => (a, a) -> Gen a
QC.choose (Int
lo, forall a. Bounded a => a
maxBound)
arbitraryIntRange (IntRange Maybe Int
Nothing   (Just Int
hi)) = forall a. Random a => (a, a) -> Gen a
QC.choose (forall a. Bounded a => a
minBound, Int
hi)
arbitraryIntRange (IntRange (Just Int
lo) (Just Int
hi)) = forall a. Random a => (a, a) -> Gen a
QC.choose (Int
lo, Int
hi)
arbitraryIntRange (IntRange Maybe Int
Nothing   Maybe Int
Nothing  ) = 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  ) = forall (f :: * -> *) a. Applicative f => a -> f a
pure UTCTime
lo
arbitraryUTCRange (UTCRange Maybe UTCTime
Nothing   (Just UTCTime
hi)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure UTCTime
hi
arbitraryUTCRange (UTCRange (Just UTCTime
lo) (Just UTCTime
hi)) = forall a. [a] -> Gen a
QC.elements [UTCTime
lo, UTCTime
hi]
arbitraryUTCRange (UTCRange Maybe UTCTime
Nothing   Maybe UTCTime
Nothing  ) = forall a. Arbitrary a => Gen a
QC.arbitrary