@@ -10,14 +10,14 @@ module Derive.API.TH
1010 , derivingOptionsToJsonOptions
1111 , deriveApiInstances
1212 , deriveApiAndArbitraryInstances
13−#ifndef ghcjs_HOST_OS
13+#ifdef BACKEND
1414 , derivingOptionsToSchemaOptions
1515 , deriveToParamSchema
1616 , deriveToSchema
17+ , deriveArbitrary
1718#endif
1819 , deriveApiFromJSON
1920 , 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
2829import Data.Maybe
29−-- import Data.Traversable
3030import Data.Typeable
3131import Language.Haskell.TH
3232import Language.Haskell.TH.Datatype
3333import Language.Haskell.TH.Syntax
34−import Test.QuickCheck
35−import Test.QuickCheck.Arbitrary.Generic
3634
37−#ifndef ghcjs_HOST_OS
35+#ifdef BACKEND
3836import Data.OpenApi hiding (prefix)
37+import Test.QuickCheck
38+import Test.QuickCheck.Arbitrary.Generic
3939#endif
4040
4141-- | derive JSON and openapi3 (ToSchema) instances
4242deriveApiInstances :: DerivingOptions -> Name -> Q [Dec]
43−#ifndef ghcjs_HOST_OS
43+#ifdef BACKEND
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−#ifndef ghcjs_HOST_OS
54+#ifdef BACKEND
5555deriveApiAndArbitraryInstances opts tname = liftM2 (<>)
5656 (deriveApiInstances opts tname)
5757 (deriveArbitrary tname)
@@ -60,13 +60,29 @@ deriveApiAndArbitraryInstances opts tname =
6060 deriveApiInstances opts tname
6161#endif
6262
63−-- We can't directly 'lift' Options into TH, so have to use this
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.
6478data DerivingOptions = DerivingOptions
6579 { prefix :: Maybe String
6680 -- ^ Optional prefix to strip from constructors and field labels
6781 , snake :: Bool
6882 -- ^ Whether to snake constructors and field labels
6983 -- Applied after stripping prefix
84+ , convertMap :: M.Map String String
85+ -- ^ convert names (constructors and fields) before snake and strip prefix
7086 , unwrapUnaryRecords :: Bool
7187 , omitNothingFields :: Bool
7288 , sumEncoding :: SumEncoding
@@ -78,53 +94,66 @@ defaultDerivingOptions :: DerivingOptions
7894defaultDerivingOptions = DerivingOptions
7995 { prefix = Nothing
8096 , snake = True
97+ , convertMap = mempty
8198 , unwrapUnaryRecords = False
8299 , omitNothingFields = False
83100 , sumEncoding = defaultTaggedObject }
84101
85102derivingOptionsToJsonOptions :: DerivingOptions -> Options
86103derivingOptionsToJsonOptions DerivingOptions{..} = defaultOptions
87− { fieldLabelModifier = snaked . stripped
88− , constructorTagModifier = snaked . stripped
104+ { fieldLabelModifier = snaked . stripped . convert
105+ , constructorTagModifier = snaked . stripped . convert
89106 , sumEncoding
90107 , omitNothingFields
91108 , unwrapUnaryRecords }
92109 where
110+ convert s = fromMaybe s $ M.lookup s convertMap
93111 snaked = if snake then camelTo2 '_' else id
94112 stripped = maybe id stripPrefix' prefix
95113
96−#ifndef ghcjs_HOST_OS
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+
97122derivingOptionsToSchemaOptions :: DerivingOptions -> SchemaOptions
98123derivingOptionsToSchemaOptions = fromAesonOptions . derivingOptionsToJsonOptions
99124
100125deriveToParamSchema :: DerivingOptions -> Name -> Q [Dec]
101126deriveToParamSchema opts tname = do
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) [] ]
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) []] ]]
109132
110133deriveToSchema :: DerivingOptions -> Name -> Q [Dec]
111134deriveToSchema opts tname = do
112135 tinfo <- reifyDatatype tname
113136 let
114−#if MIN_VERSION_th_abstraction(0,3,0)
115− tvars = VarT . tvName <$> datatypeVars tinfo
116−#else
117− tvars = datatypeVars tinfo
118−#endif
119137 context = do
120− var <- tvars
138+ var <- datatypeVarsTypes tinfo
121139 [ConT ''Typeable `AppT` var, ConT ''ToSchema `AppT` var]
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) [] ]
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) []] ] ]
128157#endif
129158
130159deriveApiFromJSON :: DerivingOptions -> Name -> Q [Dec]
@@ -138,30 +167,3 @@ generateParseJSON = mkParseJSON . derivingOptionsToJsonOptions
138167
139168stripPrefix' :: String -> String -> String
140169stripPrefix' 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− [ pure $ FunD 'arbitrary [Clause [] (NormalB ba) []]
156− , pure $ 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]