@@ -0,0 +1,122 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveLift #-}
3+{-# OPTIONS_GHC -fno-warn-orphans #-}
4+
5+module Data.API.TH
6+ ( DerivingOptions(..)
7+ , SumEncoding(..)
8+ , defaultDerivingOptions
9+ , derivingOptionsToJsonOptions
10+ , derivingOptionsToSchemaOptions
11+ , deriveApiInstances
12+#ifndef ghcjs_HOST_OS
13+ , deriveToParamSchema
14+ , deriveToSchema
15+#endif
16+ , deriveApiFromJSON
17+ , deriveApiToJSON
18+ , generateParseJSON
19+ ) where
20+
21+import Control.Monad
22+import Data.Aeson.TH as A
23+import Data.Aeson.Types
24+#if MIN_VERSION_th_abstraction(0,3,0)
25+import Data.Functor
26+#endif
27+import qualified Data.List as List
28+import Data.Maybe
29+#ifndef ghcjs_HOST_OS
30+import Data.OpenApi hiding (prefix)
31+#endif
32+import Data.Typeable
33+import Language.Haskell.TH
34+import Language.Haskell.TH.Datatype
35+import Language.Haskell.TH.Syntax
36+
37+
38+-- | derive JSON and openapi3 (ToSchema) instances
39+deriveApiInstances :: DerivingOptions -> Name -> Q [Dec]
40+#ifndef ghcjs_HOST_OS
41+deriveApiInstances opts tname = liftM2 (<>)
42+ (deriveJSON (derivingOptionsToJsonOptions opts) tname)
43+ (deriveToSchema opts tname)
44+#else
45+deriveApiInstances opts tname =
46+ deriveJSON (derivingOptionsToJsonOptions opts) tname
47+#endif
48+
49+-- We can't directly 'lift' Options into TH, so have to use this
50+data DerivingOptions = DerivingOptions
51+ { prefix :: Maybe String
52+ -- ^ Optional prefix to strip from constructors and field labels
53+ , snake :: Bool
54+ -- ^ Whether to snake constructors and field labels
55+ -- Applied after stripping prefix
56+ , unwrapUnaryRecords :: Bool
57+ , sumEncoding :: SumEncoding
58+ } deriving (Lift)
59+
60+deriving instance Lift SumEncoding
61+
62+defaultDerivingOptions :: DerivingOptions
63+defaultDerivingOptions = DerivingOptions
64+ { prefix = Nothing
65+ , snake = True
66+ , unwrapUnaryRecords = True
67+ , sumEncoding = defaultTaggedObject }
68+
69+derivingOptionsToJsonOptions :: DerivingOptions -> Options
70+derivingOptionsToJsonOptions DerivingOptions{..} = defaultOptions
71+ { fieldLabelModifier = snaked . stripped
72+ , constructorTagModifier = snaked . stripped
73+ , sumEncoding
74+ , unwrapUnaryRecords }
75+ where
76+ snaked = if snake then camelTo2 '_' else id
77+ stripped = maybe id stripPrefix prefix
78+
79+#ifndef ghcjs_HOST_OS
80+derivingOptionsToSchemaOptions :: DerivingOptions -> SchemaOptions
81+derivingOptionsToSchemaOptions = fromAesonOptions . derivingOptionsToJsonOptions
82+
83+deriveToParamSchema :: DerivingOptions -> Name -> Q [Dec]
84+deriveToParamSchema opts tname = do
85+ let
86+ body = AppE (VarE 'genericToParamSchema) <$>
87+ appE (pure $ VarE 'derivingOptionsToSchemaOptions) (lift opts)
88+ pure <$> instanceD
89+ (pure [])
90+ (pure $ ConT ''ToParamSchema `AppT` ConT tname)
91+ [ funD 'toParamSchema $ pure $ clause [] (normalB body) [] ]
92+
93+deriveToSchema :: DerivingOptions -> Name -> Q [Dec]
94+deriveToSchema opts tname = do
95+ tinfo <- reifyDatatype tname
96+ let
97+ tvars = datatypeVars tinfo
98+#if MIN_VERSION_th_abstraction(0,3,0)
99+ <&> VarT . tvName
100+#endif
101+ context = do
102+ var <- tvars
103+ [ConT ''Typeable `AppT` var, ConT ''ToSchema `AppT` var]
104+ body = AppE (VarE 'genericDeclareNamedSchema) <$>
105+ appE (pure $ VarE 'derivingOptionsToSchemaOptions) (lift opts)
106+ pure <$> instanceD
107+ (pure context)
108+ (pure $ ConT ''ToSchema `AppT` datatypeType tinfo)
109+ [ funD 'declareNamedSchema $ pure $ clause [] (normalB body) [] ]
110+#endif
111+
112+deriveApiFromJSON :: DerivingOptions -> Name -> Q [Dec]
113+deriveApiFromJSON = deriveFromJSON . derivingOptionsToJsonOptions
114+
115+deriveApiToJSON :: DerivingOptions -> Name -> Q [Dec]
116+deriveApiToJSON = deriveToJSON . derivingOptionsToJsonOptions
117+
118+generateParseJSON :: DerivingOptions -> Name -> Q Exp
119+generateParseJSON = mkParseJSON . derivingOptionsToJsonOptions
120+
121+stripPrefix :: String -> String -> String
122+stripPrefix pfx = fromMaybe <*> List.stripPrefix pfx