git.iko.soy/typeable/derive-api-th
on master help sign in
swap
0d7236920 ahead, 0 behind
README.md+1−1
since splitsnapshots
unifiedsplit
@@ -1,4 +1,4 @@
1# derive-api-th
1# derive-api-th
2
2
3Derive JSON and Openapi3 instances using TH.
3Derive JSON and Openapi3 instances using TH.
4−It is convenient to derive together and drastically reduce compile time comparing with generic-base instance generation.
4+It is convenient to derive together and drastically reduce compile time comparing with generic-based instance generation.
default.nixnew file+34
@@ -0,0 +1,34 @@
1+{ reflex-platform ? ((import <nixpkgs> {}).fetchFromGitHub {
2+ owner = "reflex-frp";
3+ repo = "reflex-platform";
4+ rev = "a4664e3b99f1b89a77ac759501b6bd85e18eac95";
5+ sha256 = "1pjzjhj966rs16f4b80ir9v8d7g7q2aa0i0zs30fny3x0xk1b4ah";
6+ })
7+}:
8+(import reflex-platform { config.allowBroken = true; }).project ({ pkgs, ... }:{
9+ useWarp = true;
10+ withHoogle = false;
11+
12+ packages = {
13+ derive-api-th = ../derive-api-th;
14+ };
15+
16+ tools = _: [
17+ (pkgs.haskell.lib.dontCheck pkgs.haskellPackages.cabal-cargs)
18+ pkgs.inotify-tools
19+ ];
20+
21+ shellToolOverrides = ghc: super: {
22+ closure-compiler = null;
23+ haskell-ide-engine = null;
24+ hdevtools = null;
25+ hlint = null;
26+ stylish-haskell = null;
27+ hoogle = null;
28+ };
29+
30+ shells = {
31+ ghc = ["derive-api-th"];
32+ ghcjs = ["derive-api-th"];
33+ };
34+})
derive-api-th.cabal+35−32
@@ -1,44 +1,47 @@
1−cabal-version: 1.12
1+cabal-version: 1.12
2+name: derive-api-th
3+version: 0.1.0.0
4+description:
5+ Please see the README on GitHub at <https://github.com/typeable/derive-api-th#readme>
2
6
3−name: derive-api-th
4−version: 0.1.0.0
5−description: Please see the README on GitHub at <https://github.com/typeable/derive-api-th#readme>
6−homepage: https://github.com/typeable/derive-api-th#readme
7+homepage: https://github.com/typeable/derive-api-th#readme
7−bug-reports: https://github.com/typeable/derive-api-th/issues
8+bug-reports: https://github.com/typeable/derive-api-th/issues
8−author: Typeable
9+author: Typeable
9−maintainer: dima@typeable.io
10+maintainer: dima@typeable.io
10−copyright: 2022 Typeable LLC
11+copyright: 2022 Typeable LLC
11−license: BSD3
12+license: BSD3
12−license-file: LICENSE
13+license-file: LICENSE
13−build-type: Simple
14+build-type: Simple
14−extra-source-files:
15+extra-source-files: README.md
15− README.md
16
16
17source-repository head
17source-repository head
18− type: git
18+ type: git
19 location: https://github.com/typeable/derive-api-th
19 location: https://github.com/typeable/derive-api-th
20
20
21library
21library
22− exposed-modules:
22+ exposed-modules: Derive.API.TH
23− Derive.API.TH
24− other-modules:
25− Paths_derive_api_th
23+ other-modules: Paths_derive_api_th
26− hs-source-dirs:
24+ hs-source-dirs: src
27− src
28 build-depends:
25 build-depends:
26+ aeson
29− base >=4.7 && <5
27+ , base >=4.7 && <5
30− , aeson
28+ , containers
31 , template-haskell
29 , template-haskell
32 , th-abstraction
30 , th-abstraction
31+
33− if !impl(ghcjs)
32+ if !(impl(ghcjs) || arch(javascript) || arch(wasm32))
34 build-depends:
33 build-depends:
35− openapi3
34+ generic-arbitrary >=1.0
36− , generic-arbitrary
35+ , openapi3
37 , QuickCheck
36 , QuickCheck
37+
38+ cpp-options: -DBACKEND
39+
38− default-language: Haskell2010
40+ default-language: Haskell2010
39 default-extensions:
41 default-extensions:
42+ BlockArguments
40− DuplicateRecordFields
43+ DuplicateRecordFields
41− , NamedFieldPuns
44+ NamedFieldPuns
42− , RecordWildCards
45+ RecordWildCards
43− , StandaloneDeriving
46+ StandaloneDeriving
44− , TemplateHaskell
47+ TemplateHaskell
shell.nixnew file+1
@@ -0,0 +1 @@
1+(import ./default.nix { }).shells.ghcjs
src/Derive/API/TH.hs+79−56
@@ -9,7 +9,8 @@ module Derive.API.TH
9 , defaultDerivingOptions
9 , defaultDerivingOptions
10 , derivingOptionsToJsonOptions
10 , derivingOptionsToJsonOptions
11 , deriveApiInstances
11 , deriveApiInstances
12−#ifndef ghcjs_HOST_OS
12+ , deriveApiAndArbitraryInstances
13+#ifdef BACKEND
13 , derivingOptionsToSchemaOptions
14 , derivingOptionsToSchemaOptions
14 , deriveToParamSchema
15 , deriveToParamSchema
15 , deriveToSchema
16 , deriveToSchema
@@ -20,28 +21,26 @@ module Derive.API.TH
20 , generateParseJSON
21 , generateParseJSON
21 ) where
22 ) where
22
23
23−import Control.Monad
24+import Control.Monad
24−import Data.Aeson.TH as A
25+import Data.Aeson.TH as A
25−import Data.Aeson.Types
26+import Data.Aeson.Types
26−#if MIN_VERSION_th_abstraction(0,3,0)
27+import Data.List
27−import Data.Functor
28−#endif
29−import qualified Data.List as List
28+import Data.Map as M
30−import Data.Maybe
29+import Data.Maybe
31−import Data.Typeable
30+import Data.Typeable
32−import Language.Haskell.TH
31+import Language.Haskell.TH
33−import Language.Haskell.TH.Datatype
32+import Language.Haskell.TH.Datatype
34−import Language.Haskell.TH.Syntax
33+import Language.Haskell.TH.Syntax
35−
34+
36−#ifndef ghcjs_HOST_OS
35+#ifdef BACKEND
37−import Data.OpenApi hiding (prefix)
36+import Data.OpenApi hiding (prefix)
38−import Test.QuickCheck
37+import Test.QuickCheck
39−import Test.QuickCheck.Arbitrary.Generic
38+import Test.QuickCheck.Arbitrary.Generic
40#endif
39#endif
41
40
42-- | derive JSON and openapi3 (ToSchema) instances
41-- | derive JSON and openapi3 (ToSchema) instances
43deriveApiInstances :: DerivingOptions -> Name -> Q [Dec]
42deriveApiInstances :: DerivingOptions -> Name -> Q [Dec]
44−#ifndef ghcjs_HOST_OS
43+#ifdef BACKEND
45deriveApiInstances opts tname = liftM2 (<>)
44deriveApiInstances opts tname = liftM2 (<>)
46 (deriveJSON (derivingOptionsToJsonOptions opts) tname)
45 (deriveJSON (derivingOptionsToJsonOptions opts) tname)
47 (deriveToSchema opts tname)
46 (deriveToSchema opts tname)
@@ -50,9 +49,9 @@ deriveApiInstances opts tname =
50 deriveJSON (derivingOptionsToJsonOptions opts) tname
49 deriveJSON (derivingOptionsToJsonOptions opts) tname
51#endif
50#endif
52
51
53−-- | derive JSON and openapi3 (ToSchema) instances
52+-- | derive JSON and openapi3 (ToSchema) and Arbitrary instances
54deriveApiAndArbitraryInstances :: DerivingOptions -> Name -> Q [Dec]
53deriveApiAndArbitraryInstances :: DerivingOptions -> Name -> Q [Dec]
55−#ifndef ghcjs_HOST_OS
54+#ifdef BACKEND
56deriveApiAndArbitraryInstances opts tname = liftM2 (<>)
55deriveApiAndArbitraryInstances opts tname = liftM2 (<>)
57 (deriveApiInstances opts tname)
56 (deriveApiInstances opts tname)
58 (deriveArbitrary tname)
57 (deriveArbitrary tname)
@@ -61,14 +60,31 @@ deriveApiAndArbitraryInstances opts tname =
61 deriveApiInstances opts tname
60 deriveApiInstances opts tname
62#endif
61#endif
63
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
64−-- We can't directly 'lift' Options into TH, so have to use this
76+-- We can't directly 'lift' Options into TH (there is no instance for function),
77+-- so we use this type.
65data DerivingOptions = DerivingOptions
78data DerivingOptions = DerivingOptions
66 { prefix :: Maybe String
79 { prefix :: Maybe String
67 -- ^ Optional prefix to strip from constructors and field labels
80 -- ^ Optional prefix to strip from constructors and field labels
68 , snake :: Bool
81 , snake :: Bool
69 -- ^ Whether to snake constructors and field labels
82 -- ^ Whether to snake constructors and field labels
70 -- Applied after stripping prefix
83 -- Applied after stripping prefix
84+ , convertMap :: M.Map String String
85+ -- ^ convert names (constructors and fields) before snake and strip prefix
71 , unwrapUnaryRecords :: Bool
86 , unwrapUnaryRecords :: Bool
87+ , omitNothingFields :: Bool
72 , sumEncoding :: SumEncoding
88 , sumEncoding :: SumEncoding
73 } deriving (Lift)
89 } deriving (Lift)
74
90
@@ -78,50 +94,66 @@ defaultDerivingOptions :: DerivingOptions
78defaultDerivingOptions = DerivingOptions
94defaultDerivingOptions = DerivingOptions
79 { prefix = Nothing
95 { prefix = Nothing
80 , snake = True
96 , snake = True
97+ , convertMap = mempty
81− , unwrapUnaryRecords = True
98+ , unwrapUnaryRecords = False
99+ , omitNothingFields = False
82 , sumEncoding = defaultTaggedObject }
100 , sumEncoding = defaultTaggedObject }
83
101
84derivingOptionsToJsonOptions :: DerivingOptions -> Options
102derivingOptionsToJsonOptions :: DerivingOptions -> Options
85derivingOptionsToJsonOptions DerivingOptions{..} = defaultOptions
103derivingOptionsToJsonOptions DerivingOptions{..} = defaultOptions
86− { fieldLabelModifier = snaked . stripped
104+ { fieldLabelModifier = snaked . stripped . convert
87− , constructorTagModifier = snaked . stripped
105+ , constructorTagModifier = snaked . stripped . convert
88 , sumEncoding
106 , sumEncoding
107+ , omitNothingFields
89 , unwrapUnaryRecords }
108 , unwrapUnaryRecords }
90 where
109 where
110+ convert s = fromMaybe s $ M.lookup s convertMap
91 snaked = if snake then camelTo2 '_' else id
111 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
93
121
94−#ifndef ghcjs_HOST_OS
95derivingOptionsToSchemaOptions :: DerivingOptions -> SchemaOptions
122derivingOptionsToSchemaOptions :: DerivingOptions -> SchemaOptions
96derivingOptionsToSchemaOptions = fromAesonOptions . derivingOptionsToJsonOptions
123derivingOptionsToSchemaOptions = fromAesonOptions . derivingOptionsToJsonOptions
97
124
98deriveToParamSchema :: DerivingOptions -> Name -> Q [Dec]
125deriveToParamSchema :: DerivingOptions -> Name -> Q [Dec]
99deriveToParamSchema opts tname = do
126deriveToParamSchema opts tname = do
100− let
101− body = AppE (VarE 'genericToParamSchema) <$>
127+ body <- AppE (VarE 'genericToParamSchema)
102− appE (pure $ VarE 'derivingOptionsToSchemaOptions) (lift opts)
128+ . AppE (VarE 'derivingOptionsToSchemaOptions) <$> lift opts
103− pure <$> instanceD
129+ pure [InstanceD Nothing []
104− (pure [])
105− (pure $ ConT ''ToParamSchema `AppT` ConT tname)
130+ (ConT ''ToParamSchema `AppT` ConT tname)
106− [ funD 'toParamSchema $ pure $ clause [] (normalB body) [] ]
131+ [FunD 'toParamSchema [Clause [] (NormalB body) []] ]]
107
132
108deriveToSchema :: DerivingOptions -> Name -> Q [Dec]
133deriveToSchema :: DerivingOptions -> Name -> Q [Dec]
109deriveToSchema opts tname = do
134deriveToSchema opts tname = do
110 tinfo <- reifyDatatype tname
135 tinfo <- reifyDatatype tname
111 let
136 let
112− tvars = datatypeVars tinfo
113−#if MIN_VERSION_th_abstraction(0,3,0)
114− <&> VarT . tvName
115−#endif
116 context = do
137 context = do
117− var <- tvars
138+ var <- datatypeVarsTypes tinfo
118 [ConT ''Typeable `AppT` var, ConT ''ToSchema `AppT` var]
139 [ConT ''Typeable `AppT` var, ConT ''ToSchema `AppT` var]
119− body = AppE (VarE 'genericDeclareNamedSchema) <$>
140+ body <- AppE (VarE 'genericDeclareNamedSchema)
120− appE (pure $ VarE 'derivingOptionsToSchemaOptions) (lift opts)
141+ . AppE (VarE 'derivingOptionsToSchemaOptions) <$> lift opts
121− pure <$> instanceD
142+ pure [InstanceD Nothing context
122− (pure context)
123− (pure $ ConT ''ToSchema `AppT` datatypeType tinfo)
143+ (ConT ''ToSchema `AppT` datatypeType tinfo)
124− [ funD 'declareNamedSchema $ pure $ clause [] (normalB body) [] ]
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) []] ] ]
125#endif
157#endif
126
158
127deriveApiFromJSON :: DerivingOptions -> Name -> Q [Dec]
159deriveApiFromJSON :: DerivingOptions -> Name -> Q [Dec]
@@ -133,14 +165,5 @@ deriveApiToJSON = deriveToJSON . derivingOptionsToJsonOptions
133generateParseJSON :: DerivingOptions -> Name -> Q Exp
165generateParseJSON :: DerivingOptions -> Name -> Q Exp
134generateParseJSON = mkParseJSON . derivingOptionsToJsonOptions
166generateParseJSON = mkParseJSON . derivingOptionsToJsonOptions
135
167
136−stripPrefix :: String -> String -> String
168+stripPrefix' :: String -> String -> String
137−stripPrefix pfx = fromMaybe <*> List.stripPrefix pfx
169+stripPrefix' pfx = fromMaybe <*> 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
stack.yaml+2−1
@@ -1,4 +1,5 @@
1−resolver: lts-19.16
1+resolver: lts-22.27
2+# resolver: lts-19.16
2# resolver: lts-18.6
3# resolver: lts-18.6
3
4
4packages:
5packages: