git.iko.soy/typeable/derive-api-th
on d0bfca5 help sign in
0d72369
swap
0 ahead, 24 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+31−36
@@ -1,47 +1,42 @@
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+ Data.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−
32− if !(impl(ghcjs) || arch(javascript) || arch(wasm32))
33+ if !impl(ghcjs)
33 build-depends:
34 build-depends:
34− generic-arbitrary >=1.0
35− , openapi3
35+ openapi3
36− , QuickCheck
37−
38− cpp-options: -DBACKEND
39−
40− default-language: Haskell2010
36+ default-language: Haskell2010
41 default-extensions:
37 default-extensions:
42− BlockArguments
43− DuplicateRecordFields
38+ DuplicateRecordFields
44− NamedFieldPuns
39+ , NamedFieldPuns
45− RecordWildCards
40+ , RecordWildCards
46− StandaloneDeriving
41+ , StandaloneDeriving
47− TemplateHaskell
42+ , TemplateHaskell
shell.nixdeleted−1
@@ -1 +0,0 @@
1−(import ./default.nix { }).shells.ghcjs
src/Data/API/TH.hsnew file+122
@@ -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+derivingOptionsToSchemaOptions :: DerivingOptions -> SchemaOptions
80+derivingOptionsToSchemaOptions = fromAesonOptions . derivingOptionsToJsonOptions
81+
82+#ifndef ghcjs_HOST_OS
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
src/Derive/API/TH.hsdeleted−169
@@ -1,169 +0,0 @@
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
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: