git.iko.soy/typeable/derive-api-th
on master help sign in
initial
505e934Dmitry Olshansky
.gitignorenew file+3
compare with master
unifiedsplit
@@ -0,0 +1,3 @@
1+.stack-work/
2+*~
3+stack.yaml.lock
LICENSEnew file+30
@@ -0,0 +1,30 @@
1+Copyright Typeable LLC (c) 2022
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Author name here nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.mdnew file+4
@@ -0,0 +1,4 @@
1+# derive-api-th
2+
3+Derive JSON and Openapi3 instances using TH.
4+It is convenient to derive together and drastically reduce compile time comparing with generic-base instance generation.
derive-api-th.cabalnew file+40
@@ -0,0 +1,40 @@
1+cabal-version: 1.12
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>
6+homepage: https://github.com/typeable/derive-api-th#readme
7+bug-reports: https://github.com/typeable/derive-api-th/issues
8+author: Typeable
9+maintainer: dima@typeable.io
10+copyright: 2022 Typeable LLC
11+license: BSD3
12+license-file: LICENSE
13+build-type: Simple
14+extra-source-files:
15+ README.md
16+
17+source-repository head
18+ type: git
19+ location: https://github.com/typeable/derive-api-th
20+
21+library
22+ exposed-modules:
23+ Data.API.TH
24+ other-modules:
25+ Paths_derive_api_th
26+ hs-source-dirs:
27+ src
28+ build-depends:
29+ base >=4.7 && <5
30+ , aeson
31+ , openapi3
32+ , template-haskell
33+ , th-abstraction
34+ default-language: Haskell2010
35+ default-extensions:
36+ DuplicateRecordFields
37+ , NamedFieldPuns
38+ , RecordWildCards
39+ , StandaloneDeriving
40+ , TemplateHaskell
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+#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
stack.yamlnew file+5
@@ -0,0 +1,5 @@
1+resolver: lts-19.16
2+# resolver: lts-18.6
3+
4+packages:
5+- .