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