@@ -0,0 +1,169 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveLift #-}
3+{-# OPTIONS_GHC -fno-warn-orphans #-}
4+
5+module Derive.API.TH
6+ ( module A
7+ , DerivingOptions(..)
8+ , SumEncoding(..)
9+ , defaultDerivingOptions
10+ , derivingOptionsToJsonOptions
11+ , deriveApiInstances
12+ , deriveApiAndArbitraryInstances
13+#ifdef BACKEND
14+ , derivingOptionsToSchemaOptions
15+ , deriveToParamSchema
16+ , deriveToSchema
17+ , deriveArbitrary
18+#endif
19+ , deriveApiFromJSON
20+ , deriveApiToJSON
21+ , generateParseJSON
22+ ) where
23+
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
39+#endif
40+
41+-- | derive JSON and openapi3 (ToSchema) instances
42+deriveApiInstances :: DerivingOptions -> Name -> Q [Dec]
43+#ifdef BACKEND
44+deriveApiInstances opts tname = liftM2 (<>)
45+ (deriveJSON (derivingOptionsToJsonOptions opts) tname)
46+ (deriveToSchema opts tname)
47+#else
48+deriveApiInstances opts tname =
49+ deriveJSON (derivingOptionsToJsonOptions opts) tname
50+#endif
51+
52+-- | derive JSON and openapi3 (ToSchema) and Arbitrary instances
53+deriveApiAndArbitraryInstances :: DerivingOptions -> Name -> Q [Dec]
54+#ifdef BACKEND
55+deriveApiAndArbitraryInstances opts tname = liftM2 (<>)
56+ (deriveApiInstances opts tname)
57+ (deriveArbitrary tname)
58+#else
59+deriveApiAndArbitraryInstances opts tname =
60+ deriveApiInstances opts tname
61+#endif
62+
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.
78+data DerivingOptions = DerivingOptions
79+ { prefix :: Maybe String
80+ -- ^ Optional prefix to strip from constructors and field labels
81+ , snake :: Bool
82+ -- ^ Whether to snake constructors and field labels
83+ -- Applied after stripping prefix
84+ , convertMap :: M.Map String String
85+ -- ^ convert names (constructors and fields) before snake and strip prefix
86+ , unwrapUnaryRecords :: Bool
87+ , omitNothingFields :: Bool
88+ , sumEncoding :: SumEncoding
89+ } deriving (Lift)
90+
91+deriving instance Lift SumEncoding
92+
93+defaultDerivingOptions :: DerivingOptions
94+defaultDerivingOptions = DerivingOptions
95+ { prefix = Nothing
96+ , snake = True
97+ , convertMap = mempty
98+ , unwrapUnaryRecords = False
99+ , omitNothingFields = False
100+ , sumEncoding = defaultTaggedObject }
101+
102+derivingOptionsToJsonOptions :: DerivingOptions -> Options
103+derivingOptionsToJsonOptions DerivingOptions{..} = defaultOptions
104+ { fieldLabelModifier = snaked . stripped . convert
105+ , constructorTagModifier = snaked . stripped . convert
106+ , sumEncoding
107+ , omitNothingFields
108+ , unwrapUnaryRecords }
109+ where
110+ convert s = fromMaybe s $ M.lookup s convertMap
111+ 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
121+
122+derivingOptionsToSchemaOptions :: DerivingOptions -> SchemaOptions
123+derivingOptionsToSchemaOptions = fromAesonOptions . derivingOptionsToJsonOptions
124+
125+deriveToParamSchema :: DerivingOptions -> Name -> Q [Dec]
126+deriveToParamSchema 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) []] ]]
132+
133+deriveToSchema :: DerivingOptions -> Name -> Q [Dec]
134+deriveToSchema opts tname = do
135+ tinfo <- reifyDatatype tname
136+ let
137+ context = do
138+ var <- datatypeVarsTypes tinfo
139+ [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) []] ] ]
157+#endif
158+
159+deriveApiFromJSON :: DerivingOptions -> Name -> Q [Dec]
160+deriveApiFromJSON = deriveFromJSON . derivingOptionsToJsonOptions
161+
162+deriveApiToJSON :: DerivingOptions -> Name -> Q [Dec]
163+deriveApiToJSON = deriveToJSON . derivingOptionsToJsonOptions
164+
165+generateParseJSON :: DerivingOptions -> Name -> Q Exp
166+generateParseJSON = mkParseJSON . derivingOptionsToJsonOptions
167+
168+stripPrefix' :: String -> String -> String
169+stripPrefix' pfx = fromMaybe <*> stripPrefix pfx