{-# 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 -> ExpQ -> Q [Dec]
mk_instance ToolSettings
ts APINode
an SpecNewtype
sn [e| QC.arbitraryBoundedIntegral |]
            | Bool
otherwise             -> ToolSettings -> APINode -> SpecNewtype -> ExpQ -> Q [Dec]
mk_instance ToolSettings
ts APINode
an SpecNewtype
sn [e| arbitrary |]
    Just (FtrIntg IntRange
ir)               -> ToolSettings -> APINode -> SpecNewtype -> ExpQ -> Q [Dec]
mk_instance ToolSettings
ts APINode
an SpecNewtype
sn [e| arbitraryIntRange ir |]
    Just (FtrUTC UTCRange
ur)                -> ToolSettings -> APINode -> SpecNewtype -> ExpQ -> Q [Dec]
mk_instance ToolSettings
ts APINode
an SpecNewtype
sn [e| arbitraryUTCRange ur |]
    Just (FtrStrg RegEx
_)                -> [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  where
    mk_instance :: ToolSettings -> APINode -> SpecNewtype -> ExpQ -> Q [Dec]
mk_instance ToolSettings
ts APINode
an SpecNewtype
sn ExpQ
arb = ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''Arbitrary [APINode -> TypeQ
nodeRepT APINode
an]
                                  [Name -> ExpQ -> 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 = (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 -> ExpQ -> DecQ
simpleD 'arbitrary (APINode -> SpecRecord -> ExpQ
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 -> ExpQ
bdy APINode
an SpecRecord
sr = do Name
x <- String -> Q Name
newName String
"x"
                   ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'QC.sized) (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ [PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP Name
x] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$
                     ExpQ -> [ExpQ] -> ExpQ
applicativeE (APINode -> ExpQ
nodeConE APINode
an) ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$
                     Int -> ExpQ -> [ExpQ]
forall a. Int -> a -> [a]
replicate ([(FieldName, FieldType)] -> 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) (ExpQ -> [ExpQ]) -> ExpQ -> [ExpQ]
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 = (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 -> ExpQ -> DecQ
simpleD 'arbitrary (APINode -> SpecUnion -> ExpQ
bdy APINode
an SpecUnion
su)]
  where
    bdy :: APINode -> SpecUnion -> ExpQ
bdy APINode
an SpecUnion
su | [(FieldName, (APIType, String))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (SpecUnion -> [(FieldName, (APIType, String))]
suFields SpecUnion
su) = APINode -> ExpQ
nodeConE APINode
an
              | Bool
otherwise          = [e| oneof $(listE alts) |]
      where
        alts :: [ExpQ]
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 = (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 -> ExpQ -> DecQ
simpleD 'arbitrary (APINode -> SpecEnum -> ExpQ
bdy APINode
an SpecEnum
se)]
  where
    bdy :: APINode -> SpecEnum -> ExpQ
bdy APINode
an SpecEnum
se | [ExpQ] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExpQ]
ks   = APINode -> ExpQ
nodeConE APINode
an
              | Bool
otherwise = Name -> ExpQ
varE 'elements ExpQ -> ExpQ -> ExpQ
`appE` [ExpQ] -> ExpQ
listE [ExpQ]
ks
      where
        ks :: [ExpQ]
ks = ((FieldName, String) -> ExpQ) -> [(FieldName, String)] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (APINode -> FieldName -> ExpQ
nodeAltConE APINode
an (FieldName -> ExpQ)
-> ((FieldName, String) -> FieldName)
-> (FieldName, String)
-> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldName, String) -> FieldName
forall a b. (a, b) -> a
fst) ([(FieldName, String)] -> [ExpQ])
-> [(FieldName, String)] -> [ExpQ]
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 (f :: * -> *) a. Applicative f => a -> f a
pure UTCTime
lo
arbitraryUTCRange (UTCRange Maybe UTCTime
Nothing   (Just UTCTime
hi)) = UTCTime -> Gen UTCTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTCTime
hi
arbitraryUTCRange (UTCRange (Just UTCTime
lo) (Just UTCTime
hi)) = [UTCTime] -> Gen UTCTime
forall a. [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