{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.API.Tools.Example
( Example(..)
, exampleTool
, samplesTool
) 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.Aeson
import qualified Data.ByteString.Char8 as B
import Data.Monoid
import Data.Time
import Language.Haskell.TH
import Test.QuickCheck as QC
import qualified Data.Text as T
import Prelude
class Example a where
example :: Gen a
default example :: Arbitrary a => Gen a
example = forall a. Arbitrary a => Gen a
arbitrary
instance Example a => Example (Maybe a) where
example :: Gen (Maybe a)
example = forall a. [Gen a] -> Gen a
oneof [forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Example a => Gen a
example]
instance Example a => Example [a] where
example :: Gen [a]
example = forall a. Gen a -> Gen [a]
listOf forall a. Example a => Gen a
example
instance Example Int where
example :: Gen Int
example = forall a. (Bounded a, Integral a) => Gen a
arbitrarySizedBoundedIntegral forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (forall a. Ord a => a -> a -> Bool
> Int
0)
instance Example Bool where
example :: Gen Bool
example = forall a. Random a => (a, a) -> Gen a
choose (Bool
False, Bool
True)
instance Example T.Text where
example :: Gen Text
example = forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Mary had a little lamb"
instance Example Binary where
example :: Gen Binary
example = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> Binary
Binary forall a b. (a -> b) -> a -> b
$ String -> ByteString
B.pack String
"lots of 1s and 0s"
instance Example Value where
example :: Gen Value
example = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
"an example JSON value"
instance Example UTCTime where
example :: Gen UTCTime
example = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> UTCTime
unsafeParseUTC Text
"2013-06-09T15:52:30Z"
samplesTool :: Name -> APITool
samplesTool :: Name -> APITool
samplesTool Name
nm = forall a. (a -> Q [Dec]) -> Tool a
simpleTool forall a b. (a -> b) -> a -> b
$ \ API
api ->
Name -> TypeQ -> ExpQ -> Q [Dec]
simpleSigD Name
nm [t| [(String, Gen Value)] |]
(forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [ APINode -> ExpQ
gen_sample APINode
nd | ThNode APINode
nd <- API
api ])
where
gen_sample :: APINode -> ExpQ
gen_sample :: APINode -> ExpQ
gen_sample APINode
an = [e| ($str, fmap toJSON (example :: Gen $(nodeT an))) |]
where
str :: ExpQ
str = forall (m :: * -> *). Quote m => String -> m Exp
stringE forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ TypeName -> Text
_TypeName forall a b. (a -> b) -> a -> b
$ APINode -> TypeName
anName APINode
an
exampleTool :: APITool
exampleTool :: APITool
exampleTool = 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_ex Tool (APINode, SpecRecord)
gen_sr_ex Tool (APINode, SpecUnion)
gen_su_ex Tool (APINode, SpecEnum)
gen_se_ex forall a. Monoid a => a
mempty
gen_sn_ex :: Tool (APINode, SpecNewtype)
gen_sn_ex :: Tool (APINode, SpecNewtype)
gen_sn_ex = 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
Just (FtrStrg RegEx
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return []
Just Filter
_ -> ToolSettings -> APINode -> ExpQ -> Q [Dec]
inst ToolSettings
ts APINode
an [e| QC.arbitrary |]
Maybe Filter
Nothing -> ToolSettings -> APINode -> ExpQ -> Q [Dec]
inst ToolSettings
ts APINode
an [e| fmap $(nodeNewtypeConE ts an sn) example |]
where
inst :: ToolSettings -> APINode -> ExpQ -> Q [Dec]
inst ToolSettings
ts APINode
an ExpQ
e = ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''Example [APINode -> TypeQ
nodeRepT APINode
an] [Name -> ExpQ -> DecQ
simpleD 'example ExpQ
e]
gen_sr_ex :: Tool (APINode, SpecRecord)
gen_sr_ex :: Tool (APINode, SpecRecord)
gen_sr_ex = 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 ''Example [APINode -> TypeQ
nodeRepT APINode
an] [Name -> ExpQ -> DecQ
simpleD 'example (APINode -> SpecRecord -> ExpQ
bdy APINode
an SpecRecord
sr)]
where
bdy :: APINode -> SpecRecord -> ExpQ
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
$
ExpQ -> [ExpQ] -> ExpQ
applicativeE (APINode -> ExpQ
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) example |]
gen_su_ex :: Tool (APINode, SpecUnion)
gen_su_ex :: Tool (APINode, SpecUnion)
gen_su_ex = 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 ''Example [APINode -> TypeQ
nodeRepT APINode
an] [Name -> ExpQ -> DecQ
simpleD 'example (APINode -> SpecUnion -> ExpQ
bdy APINode
an SpecUnion
su)]
where
bdy :: APINode -> SpecUnion -> ExpQ
bdy APINode
an SpecUnion
su | 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 an su)) |]
alts :: APINode -> SpecUnion -> [ExpQ]
alts APINode
an SpecUnion
su = [ [e| fmap $(nodeAltConE an k) example |]
| (FieldName
k,(APIType, String)
_) <- SpecUnion -> [(FieldName, (APIType, String))]
suFields SpecUnion
su ]
gen_se_ex :: Tool (APINode, SpecEnum)
gen_se_ex :: Tool (APINode, SpecEnum)
gen_se_ex = forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecEnum
_) -> ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''Example [APINode -> TypeQ
nodeRepT APINode
an] []