@@ -9,8 +9,7 @@ module Derive.API.TH
99 , defaultDerivingOptions
1010 , derivingOptionsToJsonOptions
1111 , deriveApiInstances
12− , deriveApiAndArbitraryInstances
13−#ifdef BACKEND
12+#ifndef ghcjs_HOST_OS
1413 , derivingOptionsToSchemaOptions
1514 , deriveToParamSchema
1615 , deriveToSchema
@@ -21,26 +20,28 @@ module Derive.API.TH
2120 , generateParseJSON
2221 ) where
2322
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
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
3940#endif
4041
4142-- | derive JSON and openapi3 (ToSchema) instances
4243deriveApiInstances :: DerivingOptions -> Name -> Q [Dec]
43−#ifdef BACKEND
44+#ifndef ghcjs_HOST_OS
4445deriveApiInstances opts tname = liftM2 (<>)
4546 (deriveJSON (derivingOptionsToJsonOptions opts) tname)
4647 (deriveToSchema opts tname)
@@ -49,9 +50,9 @@ deriveApiInstances opts tname =
4950 deriveJSON (derivingOptionsToJsonOptions opts) tname
5051#endif
5152
52−-- | derive JSON and openapi3 (ToSchema) and Arbitrary instances
53+-- | derive JSON and openapi3 (ToSchema) instances
5354deriveApiAndArbitraryInstances :: DerivingOptions -> Name -> Q [Dec]
54−#ifdef BACKEND
55+#ifndef ghcjs_HOST_OS
5556deriveApiAndArbitraryInstances opts tname = liftM2 (<>)
5657 (deriveApiInstances opts tname)
5758 (deriveArbitrary tname)
@@ -60,31 +61,14 @@ deriveApiAndArbitraryInstances opts tname =
6061 deriveApiInstances opts tname
6162#endif
6263
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.
64+-- We can't directly 'lift' Options into TH, so have to use this
7865data DerivingOptions = DerivingOptions
7966 { prefix :: Maybe String
8067 -- ^ Optional prefix to strip from constructors and field labels
8168 , snake :: Bool
8269 -- ^ Whether to snake constructors and field labels
8370 -- Applied after stripping prefix
84− , convertMap :: M.Map String String
85− -- ^ convert names (constructors and fields) before snake and strip prefix
8671 , unwrapUnaryRecords :: Bool
87− , omitNothingFields :: Bool
8872 , sumEncoding :: SumEncoding
8973 } deriving (Lift)
9074
@@ -94,66 +78,50 @@ defaultDerivingOptions :: DerivingOptions
9478defaultDerivingOptions = DerivingOptions
9579 { prefix = Nothing
9680 , snake = True
97− , convertMap = mempty
98− , unwrapUnaryRecords = False
99− , omitNothingFields = False
81+ , unwrapUnaryRecords = True
10082 , sumEncoding = defaultTaggedObject }
10183
10284derivingOptionsToJsonOptions :: DerivingOptions -> Options
10385derivingOptionsToJsonOptions DerivingOptions{..} = defaultOptions
104− { fieldLabelModifier = snaked . stripped . convert
105− , constructorTagModifier = snaked . stripped . convert
86+ { fieldLabelModifier = snaked . stripped
87+ , constructorTagModifier = snaked . stripped
10688 , sumEncoding
107− , omitNothingFields
10889 , unwrapUnaryRecords }
10990 where
110− convert s = fromMaybe s $ M.lookup s convertMap
11191 snaked = if snake then camelTo2 '_' else id
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
92+ stripped = maybe id stripPrefix prefix
12193
94+#ifndef ghcjs_HOST_OS
12295derivingOptionsToSchemaOptions :: DerivingOptions -> SchemaOptions
12396derivingOptionsToSchemaOptions = fromAesonOptions . derivingOptionsToJsonOptions
12497
12598deriveToParamSchema :: DerivingOptions -> Name -> Q [Dec]
12699deriveToParamSchema 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) []] ]]
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) [] ]
132107
133108deriveToSchema :: DerivingOptions -> Name -> Q [Dec]
134109deriveToSchema opts tname = do
135110 tinfo <- reifyDatatype tname
136111 let
112+ tvars = datatypeVars tinfo
113+#if MIN_VERSION_th_abstraction(0,3,0)
114+ <&> VarT . tvName
115+#endif
137116 context = do
138− var <- datatypeVarsTypes tinfo
117+ var <- tvars
139118 [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) []] ] ]
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) [] ]
157125#endif
158126
159127deriveApiFromJSON :: DerivingOptions -> Name -> Q [Dec]
@@ -165,5 +133,14 @@ deriveApiToJSON = deriveToJSON . derivingOptionsToJsonOptions
165133generateParseJSON :: DerivingOptions -> Name -> Q Exp
166134generateParseJSON = mkParseJSON . derivingOptionsToJsonOptions
167135
168−stripPrefix' :: String -> String -> String
169−stripPrefix' pfx = fromMaybe <*> stripPrefix pfx
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