master..a218010 · typeable/derive-api-th

git.iko.soy/typeable/derive-api-th

on a218010 help sign in

4 files changed+51−105

since splitsnapshots

unifiedsplit

default.nix−34 derive-api-th.cabal+34−36 shell.nix−1 src/Derive/API/TH.hs+17−34

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+34−36

@@ -1,47 +1,45 @@

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>

1+cabal-version: 1.12

7−homepage: https://github.com/typeable/derive-api-th#readme

8−bug-reports: https://github.com/typeable/derive-api-th/issues

9−author: Typeable

10−maintainer: dima@typeable.io

11−copyright: 2022 Typeable LLC

12−license: BSD3

13−license-file: LICENSE

14−build-type: Simple

15−extra-source-files: README.md

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

1616

1717source-repository head

18− type: git

18+ type: git

1919 location: https://github.com/typeable/derive-api-th

2020

2121library

22− exposed-modules: Derive.API.TH

23− other-modules: Paths_derive_api_th

24− hs-source-dirs: src

22+ exposed-modules:

23+ Derive.API.TH

24+ other-modules:

25+ Paths_derive_api_th

26+ hs-source-dirs:

27+ src

2528 build-depends:

26− aeson

27− , base >=4.7 && <5

28− , containers

29+ base >=4.7 && <5

30+ , aeson

2931 , template-haskell

3032 , th-abstraction

31−

32− if !(impl(ghcjs) || arch(javascript) || arch(wasm32))

33+ , generic-arbitrary

34+ , QuickCheck

35+ if !impl(ghcjs)

3336 build-depends:

34− generic-arbitrary >=1.0

35− , openapi3

36− , QuickCheck

37−

38− cpp-options: -DBACKEND

39−

40− default-language: Haskell2010

37+ openapi3

38+ default-language: Haskell2010

4139 default-extensions:

42− BlockArguments

43− DuplicateRecordFields

44− NamedFieldPuns

45− RecordWildCards

46− StandaloneDeriving

47− TemplateHaskell

40+ BlockArguments

41+ , DuplicateRecordFields

42+ , NamedFieldPuns

43+ , RecordWildCards

44+ , StandaloneDeriving

45+ , TemplateHaskell

shell.nixdeleted−1

@@ -1 +0,0 @@

1−(import ./default.nix { }).shells.ghcjs

src/Derive/API/TH.hs+17−34

@@ -10,7 +10,7 @@ module Derive.API.TH

1010 , derivingOptionsToJsonOptions

1111 , deriveApiInstances

1212 , deriveApiAndArbitraryInstances

13−#ifdef BACKEND

13+#ifndef ghcjs_HOST_OS

1414 , derivingOptionsToSchemaOptions

1515 , deriveToParamSchema

1616 , deriveToSchema

@@ -25,22 +25,21 @@ import Control.Monad

2525import Data.Aeson.TH as A

2626import Data.Aeson.Types

2727import Data.List

28−import Data.Map as M

2928import Data.Maybe

3029import Data.Typeable

3130import Language.Haskell.TH

3231import Language.Haskell.TH.Datatype

3332import Language.Haskell.TH.Syntax

34−

35−#ifdef BACKEND

36−import Data.OpenApi hiding (prefix)

3733import Test.QuickCheck

3834import Test.QuickCheck.Arbitrary.Generic

35+

36+#ifndef ghcjs_HOST_OS

37+import Data.OpenApi hiding (prefix)

3938#endif

4039

4140-- | derive JSON and openapi3 (ToSchema) instances

4241deriveApiInstances :: DerivingOptions -> Name -> Q [Dec]

43−#ifdef BACKEND

42+#ifndef ghcjs_HOST_OS

4443deriveApiInstances opts tname = liftM2 (<>)

4544 (deriveJSON (derivingOptionsToJsonOptions opts) tname)

4645 (deriveToSchema opts tname)

@@ -51,7 +50,7 @@ deriveApiInstances opts tname =

5150

5251-- | derive JSON and openapi3 (ToSchema) and Arbitrary instances

5352deriveApiAndArbitraryInstances :: DerivingOptions -> Name -> Q [Dec]

54−#ifdef BACKEND

53+#ifndef ghcjs_HOST_OS

5554deriveApiAndArbitraryInstances opts tname = liftM2 (<>)

5655 (deriveApiInstances opts tname)

5756 (deriveArbitrary tname)

@@ -60,29 +59,14 @@ deriveApiAndArbitraryInstances opts tname =

6059 deriveApiInstances opts tname

6160#endif

6261

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

7662-- We can't directly 'lift' Options into TH (there is no instance for function),

7763-- so we use this type.

7864data DerivingOptions = DerivingOptions

7965 { prefix :: Maybe String

80− -- ^ Optional prefix to strip from constructors and field labels

66+ -- ^ Optional prefix to strip from constructors and field labels

8167 , snake :: Bool

8268 -- ^ Whether to snake constructors and field labels

8369 -- Applied after stripping prefix

84− , convertMap :: M.Map String String

85− -- ^ convert names (constructors and fields) before snake and strip prefix

8670 , unwrapUnaryRecords :: Bool

8771 , omitNothingFields :: Bool

8872 , sumEncoding :: SumEncoding

@@ -94,29 +78,27 @@ defaultDerivingOptions :: DerivingOptions

9478defaultDerivingOptions = DerivingOptions

9579 { prefix = Nothing

9680 , snake = True

97− , convertMap = mempty

9881 , unwrapUnaryRecords = False

9982 , omitNothingFields = False

10083 , sumEncoding = defaultTaggedObject }

10184

10285derivingOptionsToJsonOptions :: DerivingOptions -> Options

10386derivingOptionsToJsonOptions DerivingOptions{..} = defaultOptions

104− { fieldLabelModifier = snaked . stripped . convert

105− , constructorTagModifier = snaked . stripped . convert

87+ { fieldLabelModifier = snaked . stripped

88+ , constructorTagModifier = snaked . stripped

10689 , sumEncoding

10790 , omitNothingFields

10891 , unwrapUnaryRecords }

10992 where

110− convert s = fromMaybe s $ M.lookup s convertMap

11193 snaked = if snake then camelTo2 '_' else id

11294 stripped = maybe id stripPrefix' prefix

11395

114−#ifdef BACKEND

96+#ifndef ghcjs_HOST_OS

11597datatypeVarsTypes :: DatatypeInfo -> [Type]

11698#if MIN_VERSION_th_abstraction(0,3,0)

117−datatypeVarsTypes = fmap (VarT . tvName) . datatypeVars

99+datatypeVarsTypes = fmap (VarT . tvName) . datatypeVars

118100#else

119−datatypeVarsTypes = datatypeVars

101+datatypeVarsTypes = datatypeVars

120102#endif

121103

122104derivingOptionsToSchemaOptions :: DerivingOptions -> SchemaOptions

@@ -124,7 +106,7 @@ derivingOptionsToSchemaOptions = fromAesonOptions . derivingOptionsToJsonOptions

124106

125107deriveToParamSchema :: DerivingOptions -> Name -> Q [Dec]

126108deriveToParamSchema opts tname = do

127− body <- AppE (VarE 'genericToParamSchema)

109+ body <- AppE (VarE 'genericToParamSchema)

128110 . AppE (VarE 'derivingOptionsToSchemaOptions) <$> lift opts

129111 pure [InstanceD Nothing []

130112 (ConT ''ToParamSchema `AppT` ConT tname)

@@ -144,11 +126,11 @@ deriveToSchema opts tname = do

144126 [ FunD 'declareNamedSchema [Clause [] (NormalB body) []] ]]

145127

146128deriveArbitrary :: Name -> Q [Dec]

147−deriveArbitrary t = do

129+deriveArbitrary t = do

148130 tinfo <- reifyDatatype t

149− let

131+ let

150132 typ = datatypeType tinfo

151− ctx = datatypeVarsTypes tinfo >>= \tv ->

133+ ctx = datatypeVarsTypes tinfo >>= \tv ->

152134 [ ConT ''Arbitrary `AppT` tv

153135 , ConT ''Arg `AppT` typ `AppT` tv ]

154136 pure [InstanceD Nothing ctx (ConT ''Arbitrary `AppT` typ)

@@ -167,3 +149,4 @@ generateParseJSON = mkParseJSON . derivingOptionsToJsonOptions

167149

168150stripPrefix' :: String -> String -> String

169151stripPrefix' pfx = fromMaybe <*> stripPrefix pfx

152+