@@ -10,14 +10,14 @@ module Derive.API.TH
1010 , derivingOptionsToJsonOptions
1111 , deriveApiInstances
1212 , deriveApiAndArbitraryInstances
13−#ifdef BACKEND
13+#ifndef ghcjs_HOST_OS
1414 , derivingOptionsToSchemaOptions
1515 , deriveToParamSchema
1616 , deriveToSchema
17− , deriveArbitrary
1817#endif
1918 , deriveApiFromJSON
2019 , deriveApiToJSON
20+ , deriveArbitrary
2121 , generateParseJSON
2222 ) where
2323
@@ -25,22 +25,22 @@ import Control.Monad
2525import Data.Aeson.TH as A
2626import Data.Aeson.Types
2727import Data.List
28−import Data.Map as M
2928import Data.Maybe
29+-- import Data.Traversable
3030import Data.Typeable
3131import Language.Haskell.TH
3232import Language.Haskell.TH.Datatype
3333import Language.Haskell.TH.Syntax
34−
35−#ifdef BACKEND
36−import Data.OpenApi hiding (prefix)
3734import Test.QuickCheck
3835import Test.QuickCheck.Arbitrary.Generic
36+
37+#ifndef ghcjs_HOST_OS
38+import Data.OpenApi hiding (prefix)
3939#endif
4040
4141-- | derive JSON and openapi3 (ToSchema) instances
4242deriveApiInstances :: DerivingOptions -> Name -> Q [Dec]
43−#ifdef BACKEND
43+#ifndef ghcjs_HOST_OS
4444deriveApiInstances opts tname = liftM2 (<>)
4545 (deriveJSON (derivingOptionsToJsonOptions opts) tname)
4646 (deriveToSchema opts tname)
@@ -51,7 +51,7 @@ deriveApiInstances opts tname =
5151
5252-- | derive JSON and openapi3 (ToSchema) and Arbitrary instances
5353deriveApiAndArbitraryInstances :: DerivingOptions -> Name -> Q [Dec]
54−#ifdef BACKEND
54+#ifndef ghcjs_HOST_OS
5555deriveApiAndArbitraryInstances opts tname = liftM2 (<>)
5656 (deriveApiInstances opts tname)
5757 (deriveArbitrary tname)
@@ -60,29 +60,13 @@ deriveApiAndArbitraryInstances opts tname =
6060 deriveApiInstances opts tname
6161#endif
6262
63−#if MIN_VERSION_containers(0,6,6)
64−#elif MIN_VERSION_template_haskell(2,17,0)
65−instance (Lift k, Lift a) => Lift (Map k a) where
66− liftTyped x = unsafeCodeCoerce (lift x)
67− lift m = [|M.fromList (M.toList m)|]
68−#elif MIN_VERSION_template_haskell(2,16,0)
69−instance (Lift k, Lift a) => Lift (Map k a) where
70− liftTyped x = unsafeTExpCoerce (lift x)
71− lift m = [|M.fromList (M.toList m)|]
72−#else
73−instance (Lift k, Lift a) => Lift (Map k a) where
74− lift m = [|M.fromList (M.toList m)|]
75−#endif
76−-- We can't directly 'lift' Options into TH (there is no instance for function),
77−-- so we use this type.
63+-- We can't directly 'lift' Options into TH, so have to use this
7864data DerivingOptions = DerivingOptions
7965 { prefix :: Maybe String
8066 -- ^ Optional prefix to strip from constructors and field labels
8167 , snake :: Bool
8268 -- ^ Whether to snake constructors and field labels
8369 -- Applied after stripping prefix
84− , convertMap :: M.Map String String
85− -- ^ convert names (constructors and fields) before snake and strip prefix
8670 , unwrapUnaryRecords :: Bool
8771 , omitNothingFields :: Bool
8872 , sumEncoding :: SumEncoding
@@ -94,66 +78,53 @@ defaultDerivingOptions :: DerivingOptions
9478defaultDerivingOptions = DerivingOptions
9579 { prefix = Nothing
9680 , snake = True
97− , convertMap = mempty
9881 , unwrapUnaryRecords = False
9982 , omitNothingFields = False
10083 , sumEncoding = defaultTaggedObject }
10184
10285derivingOptionsToJsonOptions :: DerivingOptions -> Options
10386derivingOptionsToJsonOptions DerivingOptions{..} = defaultOptions
104− { fieldLabelModifier = snaked . stripped . convert
105− , constructorTagModifier = snaked . stripped . convert
87+ { fieldLabelModifier = snaked . stripped
88+ , constructorTagModifier = snaked . stripped
10689 , sumEncoding
10790 , omitNothingFields
10891 , unwrapUnaryRecords }
10992 where
110− convert s = fromMaybe s $ M.lookup s convertMap
11193 snaked = if snake then camelTo2 '_' else id
11294 stripped = maybe id stripPrefix' prefix
11395
114−#ifdef BACKEND
115−datatypeVarsTypes :: DatatypeInfo -> [Type]
116−#if MIN_VERSION_th_abstraction(0,3,0)
117−datatypeVarsTypes = fmap (VarT . tvName) . datatypeVars
118−#else
119−datatypeVarsTypes = datatypeVars
120−#endif
121−
96+#ifndef ghcjs_HOST_OS
12297derivingOptionsToSchemaOptions :: DerivingOptions -> SchemaOptions
12398derivingOptionsToSchemaOptions = fromAesonOptions . derivingOptionsToJsonOptions
12499
125100deriveToParamSchema :: DerivingOptions -> Name -> Q [Dec]
126101deriveToParamSchema opts tname = do
127− body <- AppE (VarE 'genericToParamSchema)
128− . AppE (VarE 'derivingOptionsToSchemaOptions) <$> lift opts
129− pure [InstanceD Nothing []
130− (ConT ''ToParamSchema `AppT` ConT tname)
131− [FunD 'toParamSchema [Clause [] (NormalB body) []] ]]
102+ let
103+ body = AppE (VarE 'genericToParamSchema) <$>
104+ appE (pure $ VarE 'derivingOptionsToSchemaOptions) (lift opts)
105+ pure <$> instanceD
106+ (pure [])
107+ (pure $ ConT ''ToParamSchema `AppT` ConT tname)
108+ [ funD 'toParamSchema $ pure $ clause [] (normalB body) [] ]
132109
133110deriveToSchema :: DerivingOptions -> Name -> Q [Dec]
134111deriveToSchema opts tname = do
135112 tinfo <- reifyDatatype tname
136113 let
114+#if MIN_VERSION_th_abstraction(0,3,0)
115+ tvars = VarT . tvName <$> datatypeVars tinfo
116+#else
117+ tvars = datatypeVars tinfo
118+#endif
137119 context = do
138− var <- datatypeVarsTypes tinfo
120+ var <- tvars
139121 [ConT ''Typeable `AppT` var, ConT ''ToSchema `AppT` var]
140− body <- AppE (VarE 'genericDeclareNamedSchema)
141− . AppE (VarE 'derivingOptionsToSchemaOptions) <$> lift opts
142− pure [InstanceD Nothing context
143− (ConT ''ToSchema `AppT` datatypeType tinfo)
144− [ FunD 'declareNamedSchema [Clause [] (NormalB body) []] ]]
145−
146−deriveArbitrary :: Name -> Q [Dec]
147−deriveArbitrary t = do
148− tinfo <- reifyDatatype t
149− let
150− typ = datatypeType tinfo
151− ctx = datatypeVarsTypes tinfo >>= \tv ->
152− [ ConT ''Arbitrary `AppT` tv
153− , ConT ''Arg `AppT` typ `AppT` tv ]
154− pure [InstanceD Nothing ctx (ConT ''Arbitrary `AppT` typ)
155− [ FunD 'arbitrary [Clause [] (NormalB $ VarE 'genericArbitrary) []]
156− , FunD 'shrink [Clause [] (NormalB $ VarE 'genericShrink) []] ] ]
122+ body = AppE (VarE 'genericDeclareNamedSchema) <$>
123+ appE (pure $ VarE 'derivingOptionsToSchemaOptions) (lift opts)
124+ pure <$> instanceD
125+ (pure context)
126+ (pure $ ConT ''ToSchema `AppT` datatypeType tinfo)
127+ [ funD 'declareNamedSchema $ pure $ clause [] (normalB body) [] ]
157128#endif
158129
159130deriveApiFromJSON :: DerivingOptions -> Name -> Q [Dec]
@@ -167,3 +138,30 @@ generateParseJSON = mkParseJSON . derivingOptionsToJsonOptions
167138
168139stripPrefix' :: String -> String -> String
169140stripPrefix' pfx = fromMaybe <*> stripPrefix pfx
141+
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]