@@ -9,7 +9,8 @@ module Derive.API.TH
99 , defaultDerivingOptions
1010 , derivingOptionsToJsonOptions
1111 , deriveApiInstances
12−#ifndef ghcjs_HOST_OS
12+ , deriveApiAndArbitraryInstances
13+#ifdef BACKEND
1314 , derivingOptionsToSchemaOptions
1415 , deriveToParamSchema
1516 , deriveToSchema
@@ -20,28 +21,26 @@ module Derive.API.TH
2021 , generateParseJSON
2122 ) where
2223
23−import Control.Monad
24−import Data.Aeson.TH as A
25−import Data.Aeson.Types
26−#if MIN_VERSION_th_abstraction(0,3,0)
27−import Data.Functor
28−#endif
29−import qualified Data.List as List
30−import Data.Maybe
31−import Data.Typeable
32−import Language.Haskell.TH
33−import Language.Haskell.TH.Datatype
34−import Language.Haskell.TH.Syntax
35−
36−#ifndef ghcjs_HOST_OS
37−import Data.OpenApi hiding (prefix)
38−import Test.QuickCheck
39−import Test.QuickCheck.Arbitrary.Generic
24+import Control.Monad
25+import Data.Aeson.TH as A
26+import Data.Aeson.Types
27+import Data.List
28+import Data.Map as M
29+import Data.Maybe
30+import Data.Typeable
31+import Language.Haskell.TH
32+import Language.Haskell.TH.Datatype
33+import Language.Haskell.TH.Syntax
34+
35+#ifdef BACKEND
36+import Data.OpenApi hiding (prefix)
37+import Test.QuickCheck
38+import Test.QuickCheck.Arbitrary.Generic
4039#endif
4140
4241-- | derive JSON and openapi3 (ToSchema) instances
4342deriveApiInstances :: DerivingOptions -> Name -> Q [Dec]
44−#ifndef ghcjs_HOST_OS
43+#ifdef BACKEND
4544deriveApiInstances opts tname = liftM2 (<>)
4645 (deriveJSON (derivingOptionsToJsonOptions opts) tname)
4746 (deriveToSchema opts tname)
@@ -50,9 +49,9 @@ deriveApiInstances opts tname =
5049 deriveJSON (derivingOptionsToJsonOptions opts) tname
5150#endif
5251
53−-- | derive JSON and openapi3 (ToSchema) instances
52+-- | derive JSON and openapi3 (ToSchema) and Arbitrary instances
5453deriveApiAndArbitraryInstances :: DerivingOptions -> Name -> Q [Dec]
55−#ifndef ghcjs_HOST_OS
54+#ifdef BACKEND
5655deriveApiAndArbitraryInstances opts tname = liftM2 (<>)
5756 (deriveApiInstances opts tname)
5857 (deriveArbitrary tname)
@@ -61,14 +60,31 @@ deriveApiAndArbitraryInstances opts tname =
6160 deriveApiInstances opts tname
6261#endif
6362
64−-- 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.
6578data DerivingOptions = DerivingOptions
6679 { prefix :: Maybe String
6780 -- ^ Optional prefix to strip from constructors and field labels
6881 , snake :: Bool
6982 -- ^ Whether to snake constructors and field labels
7083 -- Applied after stripping prefix
84+ , convertMap :: M.Map String String
85+ -- ^ convert names (constructors and fields) before snake and strip prefix
7186 , unwrapUnaryRecords :: Bool
87+ , omitNothingFields :: Bool
7288 , sumEncoding :: SumEncoding
7389 } deriving (Lift)
7490
@@ -78,50 +94,66 @@ defaultDerivingOptions :: DerivingOptions
7894defaultDerivingOptions = DerivingOptions
7995 { prefix = Nothing
8096 , snake = True
81− , unwrapUnaryRecords = True
97+ , convertMap = mempty
98+ , unwrapUnaryRecords = False
99+ , omitNothingFields = False
82100 , sumEncoding = defaultTaggedObject }
83101
84102derivingOptionsToJsonOptions :: DerivingOptions -> Options
85103derivingOptionsToJsonOptions DerivingOptions{..} = defaultOptions
86− { fieldLabelModifier = snaked . stripped
87− , constructorTagModifier = snaked . stripped
104+ { fieldLabelModifier = snaked . stripped . convert
105+ , constructorTagModifier = snaked . stripped . convert
88106 , sumEncoding
107+ , omitNothingFields
89108 , unwrapUnaryRecords }
90109 where
110+ convert s = fromMaybe s $ M.lookup s convertMap
91111 snaked = if snake then camelTo2 '_' else id
92− stripped = maybe id stripPrefix prefix
112+ stripped = maybe id stripPrefix' prefix
113+
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
93121
94−#ifndef ghcjs_HOST_OS
95122derivingOptionsToSchemaOptions :: DerivingOptions -> SchemaOptions
96123derivingOptionsToSchemaOptions = fromAesonOptions . derivingOptionsToJsonOptions
97124
98125deriveToParamSchema :: DerivingOptions -> Name -> Q [Dec]
99126deriveToParamSchema opts tname = do
100− let
101− body = AppE (VarE 'genericToParamSchema) <$>
102− appE (pure $ VarE 'derivingOptionsToSchemaOptions) (lift opts)
103− pure <$> instanceD
104− (pure [])
105− (pure $ ConT ''ToParamSchema `AppT` ConT tname)
106− [ 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) []] ]]
107132
108133deriveToSchema :: DerivingOptions -> Name -> Q [Dec]
109134deriveToSchema opts tname = do
110135 tinfo <- reifyDatatype tname
111136 let
112− tvars = datatypeVars tinfo
113−#if MIN_VERSION_th_abstraction(0,3,0)
114− <&> VarT . tvName
115−#endif
116137 context = do
117− var <- tvars
138+ var <- datatypeVarsTypes tinfo
118139 [ConT ''Typeable `AppT` var, ConT ''ToSchema `AppT` var]
119− body = AppE (VarE 'genericDeclareNamedSchema) <$>
120− appE (pure $ VarE 'derivingOptionsToSchemaOptions) (lift opts)
121− pure <$> instanceD
122− (pure context)
123− (pure $ ConT ''ToSchema `AppT` datatypeType tinfo)
124− [ 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) []] ] ]
125157#endif
126158
127159deriveApiFromJSON :: DerivingOptions -> Name -> Q [Dec]
@@ -133,14 +165,5 @@ deriveApiToJSON = deriveToJSON . derivingOptionsToJsonOptions
133165generateParseJSON :: DerivingOptions -> Name -> Q Exp
134166generateParseJSON = mkParseJSON . derivingOptionsToJsonOptions
135167
136−stripPrefix :: String -> String -> String
137−stripPrefix pfx = fromMaybe <*> List.stripPrefix pfx
138−
139−#ifndef ghcjs_HOST_OS
140−deriveArbitrary :: Name -> Q [Dec]
141−deriveArbitrary t = [d|
142− instance Arbitrary $(conT t) where
143− arbitrary = genericArbitrary
144− shrink = genericShrink
145− |]
146−#endif
168+stripPrefix' :: String -> String -> String
169+stripPrefix' pfx = fromMaybe <*> stripPrefix pfx