@@ -48,7 +48,7 @@ deriveApiInstances opts tname =
4848 deriveJSON (derivingOptionsToJsonOptions opts) tname
4949#endif
5050
51−-- | derive JSON and openapi3 (ToSchema) instances
51+-- | derive JSON and openapi3 (ToSchema) and Arbitrary instances
5252deriveApiAndArbitraryInstances :: DerivingOptions -> Name -> Q [Dec]
5353#ifndef ghcjs_HOST_OS
5454deriveApiAndArbitraryInstances opts tname = liftM2 (<>)
@@ -59,10 +59,11 @@ deriveApiAndArbitraryInstances opts tname =
5959 deriveApiInstances opts tname
6060#endif
6161
62−-- We can't directly 'lift' Options into TH, so have to use this
62+-- We can't directly 'lift' Options into TH (there is no instance for function),
63+-- so we use this type.
6364data DerivingOptions = DerivingOptions
6465 { prefix :: Maybe String
65− -- ^ Optional prefix to strip from constructors and field labels
66+ -- ^ Optional prefix to strip from constructors and field labels
6667 , snake :: Bool
6768 -- ^ Whether to snake constructors and field labels
6869 -- Applied after stripping prefix
@@ -93,37 +94,48 @@ derivingOptionsToJsonOptions DerivingOptions{..} = defaultOptions
9394 stripped = maybe id stripPrefix' prefix
9495
9596#ifndef ghcjs_HOST_OS
97+datatypeVarsTypes :: DatatypeInfo -> [Type]
98+#if MIN_VERSION_th_abstraction(0,3,0)
99+datatypeVarsTypes = fmap (VarT . tvName) . datatypeVars
100+#else
101+datatypeVarsTypes = datatypeVars
102+#endif
103+
96104derivingOptionsToSchemaOptions :: DerivingOptions -> SchemaOptions
97105derivingOptionsToSchemaOptions = fromAesonOptions . derivingOptionsToJsonOptions
98106
99107deriveToParamSchema :: DerivingOptions -> Name -> Q [Dec]
100108deriveToParamSchema opts tname = do
101− let
102− body = AppE (VarE 'genericToParamSchema) <$>
103− appE (pure $ VarE 'derivingOptionsToSchemaOptions) (lift opts)
104− pure <$> instanceD
105− (pure [])
106− (pure $ ConT ''ToParamSchema `AppT` ConT tname)
107− [ funD 'toParamSchema $ pure $ clause [] (normalB body) [] ]
109+ body <- AppE (VarE 'genericToParamSchema)
110+ . AppE (VarE 'derivingOptionsToSchemaOptions) <$> lift opts
111+ pure [InstanceD Nothing []
112+ (ConT ''ToParamSchema `AppT` ConT tname)
113+ [FunD 'toParamSchema [Clause [] (NormalB body) []] ]]
108114
109115deriveToSchema :: DerivingOptions -> Name -> Q [Dec]
110116deriveToSchema opts tname = do
111117 tinfo <- reifyDatatype tname
112118 let
113−#if MIN_VERSION_th_abstraction(0,3,0)
114− tvars = VarT . tvName <$> datatypeVars tinfo
115−#else
116− tvars = datatypeVars tinfo
117−#endif
118119 context = do
119− var <- tvars
120+ var <- datatypeVarsTypes tinfo
120121 [ConT ''Typeable `AppT` var, ConT ''ToSchema `AppT` var]
121− body = AppE (VarE 'genericDeclareNamedSchema) <$>
122− appE (pure $ VarE 'derivingOptionsToSchemaOptions) (lift opts)
123− pure <$> instanceD
124− (pure context)
125− (pure $ ConT ''ToSchema `AppT` datatypeType tinfo)
126− [ funD 'declareNamedSchema $ pure $ clause [] (normalB body) [] ]
122+ body <- AppE (VarE 'genericDeclareNamedSchema)
123+ . AppE (VarE 'derivingOptionsToSchemaOptions) <$> lift opts
124+ pure [InstanceD Nothing context
125+ (ConT ''ToSchema `AppT` datatypeType tinfo)
126+ [ FunD 'declareNamedSchema [Clause [] (NormalB body) []] ]]
127+
128+deriveArbitrary :: Name -> Q [Dec]
129+deriveArbitrary t = do
130+ tinfo <- reifyDatatype t
131+ let
132+ typ = datatypeType tinfo
133+ ctx = datatypeVarsTypes tinfo >>= \tv ->
134+ [ ConT ''Arbitrary `AppT` tv
135+ , ConT ''Arg `AppT` typ `AppT` tv ]
136+ pure [InstanceD Nothing ctx (ConT ''Arbitrary `AppT` typ)
137+ [ FunD 'arbitrary [Clause [] (NormalB $ VarE 'genericArbitrary) []]
138+ , FunD 'shrink [Clause [] (NormalB $ VarE 'genericShrink) []] ] ]
127139#endif
128140
129141deriveApiFromJSON :: DerivingOptions -> Name -> Q [Dec]
@@ -138,9 +150,3 @@ generateParseJSON = mkParseJSON . derivingOptionsToJsonOptions
138150stripPrefix' :: String -> String -> String
139151stripPrefix' pfx = fromMaybe <*> stripPrefix pfx
140152
141−deriveArbitrary :: Name -> Q [Dec]
142−deriveArbitrary t = [d|
143− instance Arbitrary $(conT t) where
144− arbitrary = genericArbitrary
145− shrink = genericShrink
146− |]