git.iko.soy/typeable/derive-api-th
on master help sign in
cleanup
e3dc944odr
src/Derive/API/TH.hs+16−32
compare with master
unifiedsplit
@@ -111,13 +111,8 @@ deriveToSchema :: DerivingOptions -> Name -> Q [Dec]
111deriveToSchema opts tname = do
111deriveToSchema opts tname = do
112 tinfo <- reifyDatatype tname
112 tinfo <- reifyDatatype tname
113 let
113 let
114−#if MIN_VERSION_th_abstraction(0,3,0)
115− tvars = VarT . tvName <$> datatypeVars tinfo
116−#else
117− tvars = datatypeVars tinfo
118−#endif
119 context = do
114 context = do
120− var <- tvars
115+ var <- datatypeVarsTypes tinfo
121 [ConT ''Typeable `AppT` var, ConT ''ToSchema `AppT` var]
116 [ConT ''Typeable `AppT` var, ConT ''ToSchema `AppT` var]
122 body = AppE (VarE 'genericDeclareNamedSchema) <$>
117 body = AppE (VarE 'genericDeclareNamedSchema) <$>
123 appE (pure $ VarE 'derivingOptionsToSchemaOptions) (lift opts)
118 appE (pure $ VarE 'derivingOptionsToSchemaOptions) (lift opts)
@@ -125,6 +120,21 @@ deriveToSchema opts tname = do
125 (pure context)
120 (pure context)
126 (pure $ ConT ''ToSchema `AppT` datatypeType tinfo)
121 (pure $ ConT ''ToSchema `AppT` datatypeType tinfo)
127 [ funD 'declareNamedSchema $ pure $ clause [] (normalB body) [] ]
122 [ funD 'declareNamedSchema $ pure $ clause [] (normalB body) [] ]
123+
124+datatypeVarsTypes :: DatatypeInfo -> [Type]
125+#if MIN_VERSION_th_abstraction(0,3,0)
126+datatypeVarsTypes = fmap (VarT . tvName) . datatypeVars
127+#else
128+datatypeVarsTypes = datatypeVars
129+#endif
130+
131+deriveArbitrary :: Name -> Q [Dec]
132+deriveArbitrary t = do
133+ tinfo <- reifyDatatype t
134+ let ctx = AppT (ConT ''Arbitrary) <$> datatypeVarsTypes tinfo
135+ pure [InstanceD Nothing ctx (ConT ''Arbitrary `AppT` datatypeType tinfo)
136+ [ FunD 'arbitrary [Clause [] (NormalB $ VarE 'genericArbitrary) []]
137+ , FunD 'shrink [Clause [] (NormalB $ VarE 'genericShrink) []] ] ]
128#endif
138#endif
129
139
130deriveApiFromJSON :: DerivingOptions -> Name -> Q [Dec]
140deriveApiFromJSON :: DerivingOptions -> Name -> Q [Dec]
@@ -139,29 +149,3 @@ generateParseJSON = mkParseJSON . derivingOptionsToJsonOptions
139stripPrefix' :: String -> String -> String
149stripPrefix' :: String -> String -> String
140stripPrefix' pfx = fromMaybe <*> stripPrefix pfx
150stripPrefix' pfx = fromMaybe <*> stripPrefix pfx
141
151
142−deriveArbitrary :: Name -> Q [Dec]
143−deriveArbitrary t = do
144− tinfo <- reifyDatatype t
145− let
146−#if MIN_VERSION_th_abstraction(0,3,0)
147− tvars = VarT . tvName <$> datatypeVars tinfo
148−#else
149− tvars = datatypeVars tinfo
150−#endif
151− ctx = AppT (ConT ''Arbitrary) <$> tvars
152− ba = VarE 'genericArbitrary
153− bs = VarE 'genericShrink
154− pure [InstanceD Nothing ctx (ConT ''Arbitrary `AppT` datatypeType tinfo)
155− [ FunD 'arbitrary [Clause [] (NormalB ba) []]
156− , FunD 'shrink [Clause [] (NormalB bs) []] ] ]
157− -- (pure )
158− -- (pure $ ConT ''ToSchema `AppT` datatypeType tinfo)
159− -- [ funD 'declareNamedSchema $ pure $ clause [] (normalB body) [] ]
160− -- -- body = AppE (VarE 'genericDeclareNamedSchema) <$>
161− -- -- appE (pure $ VarE 'derivingOptionsToSchemaOptions) (lift opts)
162− -- -- pure <$> instanceD
163− -- -- (pure context)
164− -- -- (pure $ ConT ''ToSchema `AppT` datatypeType tinfo)
165− -- -- [ funD 'declareNamedSchema $ pure $ clause [] (normalB body) [] ]
166− -- decs <- [d| arbitrary = genericArbitrary; shrink = genericShrink |]
167− -- pure [InstanceD Nothing ctx (ConT ''Arbitrary `AppT` datatypeType tinfo) decs]