@@ -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,21 @@ 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
3029import Data.Typeable
3130import Language.Haskell.TH
3231import Language.Haskell.TH.Datatype
3332import Language.Haskell.TH.Syntax
34−
35−#ifdef BACKEND
36−import Data.OpenApi hiding (prefix)
3733import Test.QuickCheck
3834import Test.QuickCheck.Arbitrary.Generic
35+
36+#ifndef ghcjs_HOST_OS
37+import Data.OpenApi hiding (prefix)
3938#endif
4039
4140-- | derive JSON and openapi3 (ToSchema) instances
4241deriveApiInstances :: DerivingOptions -> Name -> Q [Dec]
43−#ifdef BACKEND
42+#ifndef ghcjs_HOST_OS
4443deriveApiInstances opts tname = liftM2 (<>)
4544 (deriveJSON (derivingOptionsToJsonOptions opts) tname)
4645 (deriveToSchema opts tname)
@@ -51,7 +50,7 @@ deriveApiInstances opts tname =
5150
5251-- | derive JSON and openapi3 (ToSchema) and Arbitrary instances
5352deriveApiAndArbitraryInstances :: DerivingOptions -> Name -> Q [Dec]
54−#ifdef BACKEND
53+#ifndef ghcjs_HOST_OS
5554deriveApiAndArbitraryInstances opts tname = liftM2 (<>)
5655 (deriveApiInstances opts tname)
5756 (deriveArbitrary tname)
@@ -60,29 +59,13 @@ deriveApiAndArbitraryInstances opts tname =
6059 deriveApiInstances opts tname
6160#endif
6261
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.
62+-- We can't directly 'lift' Options into TH, so have to use this
7863data DerivingOptions = DerivingOptions
7964 { prefix :: Maybe String
8065 -- ^ Optional prefix to strip from constructors and field labels
8166 , snake :: Bool
8267 -- ^ Whether to snake constructors and field labels
8368 -- Applied after stripping prefix
84− , convertMap :: M.Map String String
85− -- ^ convert names (constructors and fields) before snake and strip prefix
8669 , unwrapUnaryRecords :: Bool
8770 , omitNothingFields :: Bool
8871 , sumEncoding :: SumEncoding
@@ -94,41 +77,34 @@ defaultDerivingOptions :: DerivingOptions
9477defaultDerivingOptions = DerivingOptions
9578 { prefix = Nothing
9679 , snake = True
97− , convertMap = mempty
9880 , unwrapUnaryRecords = False
9981 , omitNothingFields = False
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
10789 , omitNothingFields
10890 , unwrapUnaryRecords }
10991 where
110− convert s = fromMaybe s $ M.lookup s convertMap
11192 snaked = if snake then camelTo2 '_' else id
11293 stripped = maybe id stripPrefix' prefix
11394
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−
95+#ifndef ghcjs_HOST_OS
12296derivingOptionsToSchemaOptions :: DerivingOptions -> SchemaOptions
12397derivingOptionsToSchemaOptions = fromAesonOptions . derivingOptionsToJsonOptions
12498
12599deriveToParamSchema :: DerivingOptions -> Name -> Q [Dec]
126100deriveToParamSchema 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) []] ]]
101+ let
102+ body = AppE (VarE 'genericToParamSchema) <$>
103+ appE (pure $ VarE 'derivingOptionsToSchemaOptions) (lift opts)
104+ pure <$> instanceD
105+ (pure [])
106+ (pure $ ConT ''ToParamSchema `AppT` ConT tname)
107+ [ funD 'toParamSchema $ pure $ clause [] (normalB body) [] ]
132108
133109deriveToSchema :: DerivingOptions -> Name -> Q [Dec]
134110deriveToSchema opts tname = do
@@ -137,18 +113,26 @@ deriveToSchema opts tname = do
137113 context = do
138114 var <- datatypeVarsTypes tinfo
139115 [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) []] ]]
116+ body = AppE (VarE 'genericDeclareNamedSchema) <$>
117+ appE (pure $ VarE 'derivingOptionsToSchemaOptions) (lift opts)
118+ pure <$> instanceD
119+ (pure context)
120+ (pure $ ConT ''ToSchema `AppT` datatypeType tinfo)
121+ [ funD 'declareNamedSchema $ pure $ clause [] (normalB body) [] ]
122+
123+datatypeVarsTypes :: DatatypeInfo -> [Type]
124+#if MIN_VERSION_th_abstraction(0,3,0)
125+datatypeVarsTypes = fmap (VarT . tvName) . datatypeVars
126+#else
127+datatypeVarsTypes = datatypeVars
128+#endif
145129
146130deriveArbitrary :: Name -> Q [Dec]
147−deriveArbitrary t = do
131+deriveArbitrary t = do
148132 tinfo <- reifyDatatype t
149− let
133+ let
150134 typ = datatypeType tinfo
151− ctx = datatypeVarsTypes tinfo >>= \tv ->
135+ ctx = datatypeVarsTypes tinfo >>= \tv ->
152136 [ ConT ''Arbitrary `AppT` tv
153137 , ConT ''Arg `AppT` typ `AppT` tv ]
154138 pure [InstanceD Nothing ctx (ConT ''Arbitrary `AppT` typ)
@@ -167,3 +151,4 @@ generateParseJSON = mkParseJSON . derivingOptionsToJsonOptions
167151
168152stripPrefix' :: String -> String -> String
169153stripPrefix' pfx = fromMaybe <*> stripPrefix pfx
154+