{-# 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
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
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 |]]
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
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 |]
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 ]
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
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
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