deriving-aeson 0.2.9 → 0.2.10
raw patch · 6 files changed
+506/−477 lines, 6 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ Deriving.Aeson: data StripSuffix t
+ Deriving.Aeson: instance GHC.TypeLits.KnownSymbol k => Deriving.Aeson.StringModifier (Deriving.Aeson.StripSuffix k)
+ Deriving.Aeson.Stock: type Suffixed str = CustomJSON '[FieldLabelModifier (StripSuffix str)]
+ Deriving.Aeson.Stock: type SuffixedSnake str = CustomJSON '[FieldLabelModifier '[StripSuffix str, CamelToSnake]]
- Deriving.Aeson: class FromJSON a
+ Deriving.Aeson: class () => FromJSON a
- Deriving.Aeson: class Generic a
+ Deriving.Aeson: class () => Generic a
- Deriving.Aeson: class ToJSON a
+ Deriving.Aeson: class () => ToJSON a
- Deriving.Aeson.Stock: class FromJSON a
+ Deriving.Aeson.Stock: class () => FromJSON a
- Deriving.Aeson.Stock: class Generic a
+ Deriving.Aeson.Stock: class () => Generic a
- Deriving.Aeson.Stock: class ToJSON a
+ Deriving.Aeson.Stock: class () => ToJSON a
Files
- CHANGELOG.md +63/−59
- README.md +75/−73
- deriving-aeson.cabal +36/−36
- src/Deriving/Aeson.hs +203/−193
- src/Deriving/Aeson/Stock.hs +36/−28
- tests/test.hs +93/−88
CHANGELOG.md view
@@ -1,59 +1,63 @@-# Revision history for deriving-aeson - -## 0.2.9 - -* Fixed a bug in chaining `ConstructorTagModifier` & `FieldLabelModifier` - -## 0.2.8 - -* Supported GHC 9.2 -* Supported aeson-2.0 - -## 0.2.7 - -* Added a `StringModifier` instance to a list of types -* Added `Rename :: Symbol -> Symbol -> Type` - -## 0.2.6 - -* Added `StringModifier` instances to 3 and 4-tuples -* Fixed the bug making `SumTwoElemArray` point `ObjectWithSingleField` - -## 0.2.5 - -* Added a generic `CamelTo` constructor - -## 0.2.4 - -* Added `RejectUnknownFields` - -## 0.2.3 - -* Fixed a bug in `SumTaggedObject` - -## 0.2.2 - -* Added `UnwrapUnaryRecords` - -## 0.2.1 - -* Remove redundant type variables from `Sum*` - -## 0.2 - -* Added `Sum*` for changing the encoding of variants -* Added `Vanilla = CustomJSON '[]` -* Renamed `ContructorTagModifier` to `ConstructorTagModifier` -* Added `toEncoding` implementation to `CustomJSON` - -## 0.1.2 - -* Reexported `CustomJSON(..)` from `Deriving.Aeson.Stock` - -## 0.1.1 - -* Added `Deriving.Aeson.Stock` - -## 0 -- 2020-02-26 - -* First version. Released on an unsuspecting world. +# Revision history for deriving-aeson++## 0.2.10++* Added `StripSuffix`++## 0.2.9++* Fixed a bug in chaining `ConstructorTagModifier` & `FieldLabelModifier`++## 0.2.8++* Supported GHC 9.2+* Supported aeson-2.0++## 0.2.7++* Added a `StringModifier` instance to a list of types+* Added `Rename :: Symbol -> Symbol -> Type`++## 0.2.6++* Added `StringModifier` instances to 3 and 4-tuples+* Fixed the bug making `SumTwoElemArray` point `ObjectWithSingleField`++## 0.2.5++* Added a generic `CamelTo` constructor++## 0.2.4++* Added `RejectUnknownFields`++## 0.2.3++* Fixed a bug in `SumTaggedObject`++## 0.2.2++* Added `UnwrapUnaryRecords`++## 0.2.1++* Remove redundant type variables from `Sum*`++## 0.2++* Added `Sum*` for changing the encoding of variants+* Added `Vanilla = CustomJSON '[]`+* Renamed `ContructorTagModifier` to `ConstructorTagModifier`+* Added `toEncoding` implementation to `CustomJSON`++## 0.1.2++* Reexported `CustomJSON(..)` from `Deriving.Aeson.Stock`++## 0.1.1++* Added `Deriving.Aeson.Stock`++## 0 -- 2020-02-26++* First version. Released on an unsuspecting world.
README.md view
@@ -1,73 +1,75 @@-deriving-aeson -==== - -[](https://hackage.haskell.org/package/deriving-aeson) - -[](https://discord.gg/DG93Tgs) - - - -This package provides a newtype wrapper where you can customise -[aeson](https://hackage.haskell.org/package/aeson)'s generic methods using a -type-level interface, which synergises well with DerivingVia. - -```haskell -{-# LANGUAGE DerivingVia, DataKinds, DeriveGeneric #-} -import Data.Aeson -import Deriving.Aeson -import qualified Data.ByteString.Lazy.Char8 as BL - -data User = User - { userId :: Int - , userName :: String - , userAPIToken :: Maybe String - } deriving Generic - deriving (FromJSON, ToJSON) - via CustomJSON '[OmitNothingFields, FieldLabelModifier '[StripPrefix "user", CamelToSnake]] User - -testData :: [User] -testData = [User 42 "Alice" Nothing, User 43 "Bob" (Just "xyz")] - -main = BL.putStrLn $ encode testData --- [{"name":"Alice","id":42},{"api_token":"xyz","name":"Bob","id":43}] -``` - -`Deriving.Aeson.Stock` contains some aliases for even less boilerplates. - -* `Prefixed str` = `CustomJSON '[FieldLabelModifier (StripPrefix str)]` -* `PrefixedSnake str` = `CustomJSON '[FieldLabelModifier (StripPrefix str, CamelToSnake)]` -* `Snake` = `CustomJSON '[FieldLabelModifier '[StripPrefix str, CamelToSnake]]` -* `Vanilla` = `CustomJSON '[]` - -How it works ----- - -The wrapper type has a phantom type parameter `t`, a type-level builder of an [Option](http://hackage.haskell.org/package/aeson-1.4.6.0/docs/Data-Aeson.html#t:Options). -Type-level primitives are reduced to one `Option` by the `AesonOptions` class. - -```haskell -newtype CustomJSON t a = CustomJSON { unCustomJSON :: a } - -class AesonOptions xs where - aesonOptions :: Options - -instance AesonOptions xs => AesonOptions (OmitNothingFields ': xs) where - aesonOptions = (aesonOptions @xs) { omitNothingFields = True } - -... -``` - -You can use any (static) function for name modification by adding an instance of `StringModifier`. - -```haskell -data ToLower -instance StringModifier ToLower where - getStringModifier "" = "" - getStringModifier (c : xs) = toLower c : xs -``` - -Previous studies ----- - -* [Type-driven safe derivation of ToJSON and FromJSON, using DerivingVia in GHC 8.6 and some type-level hacks](https://gist.github.com/konn/27c00f784dd883ec2b90eab8bc84a81d) -* [Strip prefices from JSON representation](https://gist.github.com/fumieval/5c89205d418d5f9cafac801afbe94969) +deriving-aeson+====++[](https://hackage.haskell.org/package/deriving-aeson)++[](https://discord.gg/DG93Tgs)++++This package provides a newtype wrapper where you can customise+[aeson](https://hackage.haskell.org/package/aeson)'s generic methods using a+type-level interface, which synergises well with DerivingVia.++```haskell+{-# LANGUAGE DerivingVia, DataKinds, DeriveGeneric #-}+import Data.Aeson+import Deriving.Aeson+import qualified Data.ByteString.Lazy.Char8 as BL++data User = User+ { userId :: Int+ , userName :: String+ , userAPIToken :: Maybe String+ } deriving Generic+ deriving (FromJSON, ToJSON)+ via CustomJSON '[OmitNothingFields, FieldLabelModifier '[StripPrefix "user", CamelToSnake]] User++testData :: [User]+testData = [User 42 "Alice" Nothing, User 43 "Bob" (Just "xyz")]++main = BL.putStrLn $ encode testData+-- [{"name":"Alice","id":42},{"api_token":"xyz","name":"Bob","id":43}]+```++`Deriving.Aeson.Stock` contains some aliases for even less boilerplates.++* `Prefixed str` = `CustomJSON '[FieldLabelModifier (StripPrefix str)]`+* `PrefixedSnake str` = `CustomJSON '[FieldLabelModifier (StripPrefix str, CamelToSnake)]`+* `Suffixed str` = `CustomJSON '[FieldLabelModifier (StripSuffix str)]`+* `SuffixedSnake str` = `CustomJSON '[FieldLabelModifier (StripSuffix str, CamelToSnake)]`+* `Snake` = `CustomJSON '[FieldLabelModifier '[StripPrefix str, CamelToSnake]]`+* `Vanilla` = `CustomJSON '[]`++How it works+----++The wrapper type has a phantom type parameter `t`, a type-level builder of an [Option](http://hackage.haskell.org/package/aeson-1.4.6.0/docs/Data-Aeson.html#t:Options).+Type-level primitives are reduced to one `Option` by the `AesonOptions` class.++```haskell+newtype CustomJSON t a = CustomJSON { unCustomJSON :: a }++class AesonOptions xs where+ aesonOptions :: Options++instance AesonOptions xs => AesonOptions (OmitNothingFields ': xs) where+ aesonOptions = (aesonOptions @xs) { omitNothingFields = True }++...+```++You can use any (static) function for name modification by adding an instance of `StringModifier`.++```haskell+data ToLower+instance StringModifier ToLower where+ getStringModifier "" = ""+ getStringModifier (c : xs) = toLower c : xs+```++Previous studies+----++* [Type-driven safe derivation of ToJSON and FromJSON, using DerivingVia in GHC 8.6 and some type-level hacks](https://gist.github.com/konn/27c00f784dd883ec2b90eab8bc84a81d)+* [Strip prefices from JSON representation](https://gist.github.com/fumieval/5c89205d418d5f9cafac801afbe94969)
deriving-aeson.cabal view
@@ -1,36 +1,36 @@-cabal-version: 2.4 -name: deriving-aeson -version: 0.2.9 -synopsis: Type driven generic aeson instance customisation -description: This package provides a newtype wrapper with - FromJSON/ToJSON instances customisable via a phantom type parameter. - The instances can be rendered to the original type using DerivingVia. -bug-reports: https://github.com/fumieval/deriving-aeson -license: BSD-3-Clause -license-file: LICENSE -author: Fumiaki Kinoshita -maintainer: fumiexcel@gmail.com -copyright: Copyright (c) 2020 Fumiaki Kinoshita -category: JSON, Generics -extra-source-files: CHANGELOG.md, README.md -tested-with: GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.7, GHC == 9.2.5, GHC == 9.4.4 - -source-repository head - type: git - location: https://github.com/fumieval/deriving-aeson.git - -library - exposed-modules: - Deriving.Aeson - Deriving.Aeson.Stock - build-depends: base >= 4.12 && <5, aeson >= 1.4.7.0 && <2.2 - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall -Wcompat - -test-suite test - type: exitcode-stdio-1.0 - main-is: test.hs - build-depends: base, aeson, deriving-aeson, bytestring - hs-source-dirs: tests - default-language: Haskell2010 +cabal-version: 2.4+name: deriving-aeson+version: 0.2.10+synopsis: Type driven generic aeson instance customisation+description: This package provides a newtype wrapper with+ FromJSON/ToJSON instances customisable via a phantom type parameter.+ The instances can be rendered to the original type using DerivingVia.+bug-reports: https://github.com/fumieval/deriving-aeson+license: BSD-3-Clause+license-file: LICENSE+author: Fumiaki Kinoshita+maintainer: fumiexcel@gmail.com+copyright: Copyright (c) 2020 Fumiaki Kinoshita+category: JSON, Generics+extra-source-files: CHANGELOG.md, README.md+tested-with: GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.7, GHC == 9.2.5, GHC == 9.4.4++source-repository head+ type: git+ location: https://github.com/fumieval/deriving-aeson.git++library+ exposed-modules:+ Deriving.Aeson+ Deriving.Aeson.Stock+ build-depends: base >= 4.12 && <5, aeson >= 1.4.7.0 && <2.3+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall -Wcompat++test-suite test+ type: exitcode-stdio-1.0+ main-is: test.hs+ build-depends: base, aeson, deriving-aeson, bytestring+ hs-source-dirs: tests+ default-language: Haskell2010
src/Deriving/Aeson.hs view
@@ -1,193 +1,203 @@-{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE UndecidableInstances #-} --------------------- --- | Type-directed aeson instance CustomJSONisation --------------------- -module Deriving.Aeson - ( CustomJSON(..) - , FieldLabelModifier - , ConstructorTagModifier - , OmitNothingFields - , RejectUnknownFields - , TagSingleConstructors - , NoAllNullaryToStringTag - , UnwrapUnaryRecords - -- * Sum encoding - , SumTaggedObject - , SumUntaggedValue - , SumObjectWithSingleField - , SumTwoElemArray - -- * Name modifiers - , StripPrefix - , CamelTo - , CamelToKebab - , CamelToSnake - , Rename - -- * Interface - , AesonOptions(..) - , StringModifier(..) - -- * Reexports - , FromJSON - , ToJSON - , Generic - )where - -import Data.Aeson -import Data.Coerce -import Data.Kind -import Data.List (stripPrefix) -import Data.Maybe (fromMaybe) -import Data.Proxy -import GHC.Generics -import GHC.TypeLits - --- | A newtype wrapper which gives FromJSON/ToJSON instances with modified options. -newtype CustomJSON t a = CustomJSON { unCustomJSON :: a } - -instance (AesonOptions t, Generic a, GFromJSON Zero (Rep a)) => FromJSON (CustomJSON t a) where - parseJSON = (coerce `asTypeOf` fmap CustomJSON) . genericParseJSON (aesonOptions @t) - {-# INLINE parseJSON #-} - -instance (AesonOptions t, Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (CustomJSON t a) where - toJSON = genericToJSON (aesonOptions @t) . unCustomJSON - {-# INLINE toJSON #-} - toEncoding = genericToEncoding (aesonOptions @t) . unCustomJSON - {-# INLINE toEncoding #-} - --- | Function applied to field labels. Handy for removing common record prefixes for example. -data FieldLabelModifier t - --- | Function applied to constructor tags which could be handy for lower-casing them for example. -data ConstructorTagModifier t - --- | Record fields with a Nothing value will be omitted from the resulting object. -data OmitNothingFields - --- | JSON Documents mapped to records with unmatched keys will be rejected -data RejectUnknownFields - --- | Encode types with a single constructor as sums, so that allNullaryToStringTag and sumEncoding apply. -data TagSingleConstructors - --- | the encoding will always follow the 'sumEncoding'. -data NoAllNullaryToStringTag - --- | Unpack single-field records -data UnwrapUnaryRecords - --- | Strip prefix @t@. If it doesn't have the prefix, keep it as-is. -data StripPrefix t - --- | Generic CamelTo constructor taking in a separator char -data CamelTo (separator :: Symbol) - --- | CamelCase to snake_case -type CamelToSnake = CamelTo "_" - --- | CamelCase to kebab-case -type CamelToKebab = CamelTo "-" - --- | Rename fields called @from@ to @to@. -data Rename (from :: Symbol) (to :: Symbol) - --- | Reify a function which modifies names -class StringModifier t where - getStringModifier :: String -> String - -instance KnownSymbol k => StringModifier (StripPrefix k) where - getStringModifier = fromMaybe <*> stripPrefix (symbolVal (Proxy @k)) - -instance StringModifier '[] where - getStringModifier = id - --- | Left-to-right (@'foldr' ('flip' ('.')) 'id'@) composition -instance (StringModifier a, StringModifier as) => StringModifier (a ': as) where - getStringModifier = getStringModifier @as . getStringModifier @a - --- | Left-to-right (@'flip' '.'@) composition -instance (StringModifier a, StringModifier b) => StringModifier (a, b) where - getStringModifier = getStringModifier @b . getStringModifier @a - --- | Left-to-right (@'flip' '.'@) composition -instance (StringModifier a, StringModifier b, StringModifier c) => StringModifier (a, b, c) where - getStringModifier = getStringModifier @c . getStringModifier @b . getStringModifier @a - --- | Left-to-right (@'flip' '.'@) composition -instance (StringModifier a, StringModifier b, StringModifier c, StringModifier d) => StringModifier (a, b, c, d) where - getStringModifier = getStringModifier @d . getStringModifier @c . getStringModifier @b . getStringModifier @a - -instance (KnownSymbol separator, NonEmptyString separator) => StringModifier (CamelTo separator) where - getStringModifier = camelTo2 char - where - char = case symbolVal (Proxy @separator) of - c : _ -> c - _ -> error "Impossible" - -instance (KnownSymbol from, KnownSymbol to) => StringModifier (Rename from to) where - getStringModifier s = if s == symbolVal (Proxy @from) then symbolVal (Proxy @to) else s - -type family NonEmptyString (xs :: Symbol) :: Constraint where - NonEmptyString "" = TypeError ('Text "Empty string separator provided for camelTo separator") - NonEmptyString _ = () - --- | @{ "tag": t, "content": c}@ -data SumTaggedObject t c - --- | @CONTENT@ -data SumUntaggedValue - --- | @{ TAG: CONTENT }@ -data SumObjectWithSingleField - --- | @[TAG, CONTENT]@ -data SumTwoElemArray - --- | Reify 'Options' from a type-level list -class AesonOptions xs where - aesonOptions :: Options - -instance AesonOptions '[] where - aesonOptions = defaultOptions - -instance AesonOptions xs => AesonOptions (UnwrapUnaryRecords ': xs) where - aesonOptions = (aesonOptions @xs) { unwrapUnaryRecords = True } - -instance AesonOptions xs => AesonOptions (OmitNothingFields ': xs) where - aesonOptions = (aesonOptions @xs) { omitNothingFields = True } - -instance AesonOptions xs => AesonOptions (RejectUnknownFields ': xs) where - aesonOptions = (aesonOptions @xs) { rejectUnknownFields = True } - -instance (StringModifier f, AesonOptions xs) => AesonOptions (FieldLabelModifier f ': xs) where - aesonOptions = let next = aesonOptions @xs in - next { fieldLabelModifier = fieldLabelModifier next . getStringModifier @f } - -instance (StringModifier f, AesonOptions xs) => AesonOptions (ConstructorTagModifier f ': xs) where - aesonOptions = let next = aesonOptions @xs in - next { constructorTagModifier = constructorTagModifier next . getStringModifier @f } - -instance AesonOptions xs => AesonOptions (TagSingleConstructors ': xs) where - aesonOptions = (aesonOptions @xs) { tagSingleConstructors = True } - -instance AesonOptions xs => AesonOptions (NoAllNullaryToStringTag ': xs) where - aesonOptions = (aesonOptions @xs) { allNullaryToStringTag = False } - -instance (KnownSymbol t, KnownSymbol c, AesonOptions xs) => AesonOptions (SumTaggedObject t c ': xs) where - aesonOptions = (aesonOptions @xs) { sumEncoding = TaggedObject (symbolVal (Proxy @t)) (symbolVal (Proxy @c)) } - -instance (AesonOptions xs) => AesonOptions (SumUntaggedValue ': xs) where - aesonOptions = (aesonOptions @xs) { sumEncoding = UntaggedValue } - -instance (AesonOptions xs) => AesonOptions (SumObjectWithSingleField ': xs) where - aesonOptions = (aesonOptions @xs) { sumEncoding = ObjectWithSingleField } - -instance (AesonOptions xs) => AesonOptions (SumTwoElemArray ': xs) where - aesonOptions = (aesonOptions @xs) { sumEncoding = TwoElemArray } +{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+--------------------+-- | Type-directed aeson instance CustomJSONisation+--------------------+module Deriving.Aeson+ ( CustomJSON(..)+ , FieldLabelModifier+ , ConstructorTagModifier+ , OmitNothingFields+ , RejectUnknownFields+ , TagSingleConstructors+ , NoAllNullaryToStringTag+ , UnwrapUnaryRecords+ -- * Sum encoding+ , SumTaggedObject+ , SumUntaggedValue+ , SumObjectWithSingleField+ , SumTwoElemArray+ -- * Name modifiers+ , StripPrefix+ , StripSuffix+ , CamelTo+ , CamelToKebab+ , CamelToSnake+ , Rename+ -- * Interface+ , AesonOptions(..)+ , StringModifier(..)+ -- * Reexports+ , FromJSON+ , ToJSON+ , Generic+ ) where++import Data.Aeson+import Data.Coerce+import Data.Kind+import Data.List (stripPrefix)+import Data.Maybe (fromMaybe)+import Data.Proxy+import GHC.Generics+import GHC.TypeLits++-- | A newtype wrapper which gives FromJSON/ToJSON instances with modified options.+newtype CustomJSON t a = CustomJSON { unCustomJSON :: a }++instance (AesonOptions t, Generic a, GFromJSON Zero (Rep a)) => FromJSON (CustomJSON t a) where+ parseJSON = (coerce `asTypeOf` fmap CustomJSON) . genericParseJSON (aesonOptions @t)+ {-# INLINE parseJSON #-}++instance (AesonOptions t, Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (CustomJSON t a) where+ toJSON = genericToJSON (aesonOptions @t) . unCustomJSON+ {-# INLINE toJSON #-}+ toEncoding = genericToEncoding (aesonOptions @t) . unCustomJSON+ {-# INLINE toEncoding #-}++-- | Function applied to field labels. Handy for removing common record prefixes for example.+data FieldLabelModifier t++-- | Function applied to constructor tags which could be handy for lower-casing them for example.+data ConstructorTagModifier t++-- | Record fields with a Nothing value will be omitted from the resulting object.+data OmitNothingFields++-- | JSON Documents mapped to records with unmatched keys will be rejected+data RejectUnknownFields++-- | Encode types with a single constructor as sums, so that allNullaryToStringTag and sumEncoding apply.+data TagSingleConstructors++-- | the encoding will always follow the 'sumEncoding'.+data NoAllNullaryToStringTag++-- | Unpack single-field records+data UnwrapUnaryRecords++-- | Strip prefix @t@. If it doesn't have the prefix, keep it as-is.+data StripPrefix t++-- | Strip suffix @t@. If it doesn't have the suffix, keep it as-is.+data StripSuffix t++-- | Generic CamelTo constructor taking in a separator char+data CamelTo (separator :: Symbol)++-- | CamelCase to snake_case+type CamelToSnake = CamelTo "_"++-- | CamelCase to kebab-case+type CamelToKebab = CamelTo "-"++-- | Rename fields called @from@ to @to@.+data Rename (from :: Symbol) (to :: Symbol)++-- | Reify a function which modifies names+class StringModifier t where+ getStringModifier :: String -> String++instance KnownSymbol k => StringModifier (StripPrefix k) where+ getStringModifier = fromMaybe <*> stripPrefix (symbolVal (Proxy @k))++stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]+stripSuffix a b = reverse <$> stripPrefix (reverse a) (reverse b)++instance KnownSymbol k => StringModifier (StripSuffix k) where+ getStringModifier = fromMaybe <*> stripSuffix (symbolVal (Proxy @k))++instance StringModifier '[] where+ getStringModifier = id++-- | Left-to-right (@'foldr' ('flip' ('.')) 'id'@) composition+instance (StringModifier a, StringModifier as) => StringModifier (a ': as) where+ getStringModifier = getStringModifier @as . getStringModifier @a++-- | Left-to-right (@'flip' '.'@) composition+instance (StringModifier a, StringModifier b) => StringModifier (a, b) where+ getStringModifier = getStringModifier @b . getStringModifier @a++-- | Left-to-right (@'flip' '.'@) composition+instance (StringModifier a, StringModifier b, StringModifier c) => StringModifier (a, b, c) where+ getStringModifier = getStringModifier @c . getStringModifier @b . getStringModifier @a++-- | Left-to-right (@'flip' '.'@) composition+instance (StringModifier a, StringModifier b, StringModifier c, StringModifier d) => StringModifier (a, b, c, d) where+ getStringModifier = getStringModifier @d . getStringModifier @c . getStringModifier @b . getStringModifier @a++instance (KnownSymbol separator, NonEmptyString separator) => StringModifier (CamelTo separator) where+ getStringModifier = camelTo2 char+ where+ char = case symbolVal (Proxy @separator) of+ c : _ -> c+ _ -> error "Impossible"++instance (KnownSymbol from, KnownSymbol to) => StringModifier (Rename from to) where+ getStringModifier s = if s == symbolVal (Proxy @from) then symbolVal (Proxy @to) else s++type family NonEmptyString (xs :: Symbol) :: Constraint where+ NonEmptyString "" = TypeError ('Text "Empty string separator provided for camelTo separator")+ NonEmptyString _ = ()++-- | @{ "tag": t, "content": c}@+data SumTaggedObject t c++-- | @CONTENT@+data SumUntaggedValue++-- | @{ TAG: CONTENT }@+data SumObjectWithSingleField++-- | @[TAG, CONTENT]@+data SumTwoElemArray++-- | Reify 'Options' from a type-level list+class AesonOptions xs where+ aesonOptions :: Options++instance AesonOptions '[] where+ aesonOptions = defaultOptions++instance AesonOptions xs => AesonOptions (UnwrapUnaryRecords ': xs) where+ aesonOptions = (aesonOptions @xs) { unwrapUnaryRecords = True }++instance AesonOptions xs => AesonOptions (OmitNothingFields ': xs) where+ aesonOptions = (aesonOptions @xs) { omitNothingFields = True }++instance AesonOptions xs => AesonOptions (RejectUnknownFields ': xs) where+ aesonOptions = (aesonOptions @xs) { rejectUnknownFields = True }++instance (StringModifier f, AesonOptions xs) => AesonOptions (FieldLabelModifier f ': xs) where+ aesonOptions = let next = aesonOptions @xs in+ next { fieldLabelModifier = fieldLabelModifier next . getStringModifier @f }++instance (StringModifier f, AesonOptions xs) => AesonOptions (ConstructorTagModifier f ': xs) where+ aesonOptions = let next = aesonOptions @xs in+ next { constructorTagModifier = constructorTagModifier next . getStringModifier @f }++instance AesonOptions xs => AesonOptions (TagSingleConstructors ': xs) where+ aesonOptions = (aesonOptions @xs) { tagSingleConstructors = True }++instance AesonOptions xs => AesonOptions (NoAllNullaryToStringTag ': xs) where+ aesonOptions = (aesonOptions @xs) { allNullaryToStringTag = False }++instance (KnownSymbol t, KnownSymbol c, AesonOptions xs) => AesonOptions (SumTaggedObject t c ': xs) where+ aesonOptions = (aesonOptions @xs) { sumEncoding = TaggedObject (symbolVal (Proxy @t)) (symbolVal (Proxy @c)) }++instance (AesonOptions xs) => AesonOptions (SumUntaggedValue ': xs) where+ aesonOptions = (aesonOptions @xs) { sumEncoding = UntaggedValue }++instance (AesonOptions xs) => AesonOptions (SumObjectWithSingleField ': xs) where+ aesonOptions = (aesonOptions @xs) { sumEncoding = ObjectWithSingleField }++instance (AesonOptions xs) => AesonOptions (SumTwoElemArray ': xs) where+ aesonOptions = (aesonOptions @xs) { sumEncoding = TwoElemArray }
src/Deriving/Aeson/Stock.hs view
@@ -1,28 +1,36 @@-{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} - -module Deriving.Aeson.Stock - ( Prefixed - , PrefixedSnake - , Snake - , Vanilla - -- * Reexports - , CustomJSON(..) - , FromJSON - , ToJSON - , Generic) where - -import Data.Kind (Type) -import Deriving.Aeson - --- | Field names are prefixed by @str@; strip them from JSON representation -type Prefixed str = CustomJSON '[FieldLabelModifier (StripPrefix str)] - --- | Strip @str@ prefices and convert from CamelCase to snake_case -type PrefixedSnake str = CustomJSON '[FieldLabelModifier '[StripPrefix str, CamelToSnake]] - --- | Convert from CamelCase to snake_case -type Snake = CustomJSON '[FieldLabelModifier CamelToSnake] - --- | No customisation -type Vanilla = CustomJSON ('[] :: [Type]) +{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}++module Deriving.Aeson.Stock+ ( Prefixed+ , PrefixedSnake+ , Suffixed+ , SuffixedSnake+ , Snake+ , Vanilla+ -- * Reexports+ , CustomJSON(..)+ , FromJSON+ , ToJSON+ , Generic) where++import Data.Kind (Type)+import Deriving.Aeson++-- | Field names are prefixed by @str@; strip them from JSON representation+type Prefixed str = CustomJSON '[FieldLabelModifier (StripPrefix str)]++-- | Strip @str@ prefices and convert from CamelCase to snake_case+type PrefixedSnake str = CustomJSON '[FieldLabelModifier '[StripPrefix str, CamelToSnake]]++-- | Field names are suffixed by @str@; strip them from JSON representation+type Suffixed str = CustomJSON '[FieldLabelModifier (StripSuffix str)]++-- | Strip @str@ suffixes and convert from CamelCase to snake_case+type SuffixedSnake str = CustomJSON '[FieldLabelModifier '[StripSuffix str, CamelToSnake]]++-- | Convert from CamelCase to snake_case+type Snake = CustomJSON '[FieldLabelModifier CamelToSnake]++-- | No customisation+type Vanilla = CustomJSON ('[] :: [Type])
tests/test.hs view
@@ -1,88 +1,93 @@-{-# LANGUAGE DerivingVia, DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import Data.Aeson -import Deriving.Aeson -import Deriving.Aeson.Stock -import System.Exit (die) -import qualified Data.ByteString.Lazy.Char8 as BL - - -data User = User - { userId :: Int - , userName :: String - , userAPIToken :: Maybe String - , userType :: String - } deriving Generic - deriving (FromJSON, ToJSON) - via CustomJSON '[ OmitNothingFields - , FieldLabelModifier '[StripPrefix "user", CamelToSnake, Rename "type" "user_type"] - ] User - -data Foo = Foo { fooFoo :: Int, fooBar :: Int } - deriving Generic - deriving (FromJSON, ToJSON) - via Prefixed "foo" Foo - -testData :: [User] -testData = [User 42 "Alice" Nothing "human", User 43 "Bob" (Just "xyz") "bot"] - -data MultipleCtorRenames - = RenamedCtorOptA - | RenamedCtorOptB (Maybe ()) - | RenamedCtorOptC Char - deriving (Eq, Generic, Show) - deriving (ToJSON) - via CustomJSON - [ ConstructorTagModifier (Rename "RenamedCtorOptA" "nullary") - , ConstructorTagModifier (Rename "RenamedCtorOptB" "twisted-bool") - , ConstructorTagModifier (Rename "RenamedCtorOptC" "wrapped-char") - ] MultipleCtorRenames - -data MultipleFieldRenames = MultipleFieldRenames - { fooField1 :: Int - , fooField2 :: Bool - , fooField3 :: String - } - deriving (Eq, Generic, Show) - deriving (ToJSON) - via CustomJSON - [ FieldLabelModifier (Rename "fooField1" "field-1") - , FieldLabelModifier (Rename "fooField2" "field-2") - , FieldLabelModifier (Rename "fooField3" "field-3") - ] MultipleFieldRenames - -main = do - BL.putStrLn $ encode testData - BL.putStrLn $ encode $ Foo 0 1 - - assertEq - (toJSON RenamedCtorOptA) - (object [("tag", "nullary")]) - "Support multiple constructor modifiers" - - assertEq - (toJSON $ RenamedCtorOptB Nothing) - (object [("tag", String "twisted-bool"), ("contents", Null)]) - "Support multiple constructor modifiers" - - assertEq - (toJSON $ RenamedCtorOptC '?') - (object [("tag", String "wrapped-char"), ("contents", String "?")]) - "Support multiple constructor modifiers" - - assertEq - (toJSON $ MultipleFieldRenames 42 True "meaning of life") - (object [("field-1", Number 42) - ,("field-2", Bool True) - ,("field-3", String "meaning of life") - ]) - "Support multiple field modifiers" - -assertEq :: (Show a, Eq a) => a -> a -> String -> IO () -assertEq x y expectation | x == y = pure () - | otherwise = die msg - where - msg = concat [expectation, " -- not fulfilled:\n\t", show x, "\n\t /= \n\t", show y] +{-# LANGUAGE DerivingVia, DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Data.Aeson+import Deriving.Aeson+import Deriving.Aeson.Stock+import System.Exit (die)+import qualified Data.ByteString.Lazy.Char8 as BL+++data User = User+ { userId :: Int+ , userName :: String+ , userAPIToken :: Maybe String+ , userType :: String+ } deriving Generic+ deriving (FromJSON, ToJSON)+ via CustomJSON '[ OmitNothingFields+ , FieldLabelModifier '[StripPrefix "user", CamelToSnake, Rename "type" "user_type"]+ ] User++data Foo = Foo { fooFoo :: Int, fooBar :: Int }+ deriving Generic+ deriving (FromJSON, ToJSON)+ via Prefixed "foo" Foo++data Something = Something { somethingKun :: Int, somethingElseKun :: Int }+ deriving Generic+ deriving (FromJSON, ToJSON) via Suffixed "Kun" Something++testData :: [User]+testData = [User 42 "Alice" Nothing "human", User 43 "Bob" (Just "xyz") "bot"]++data MultipleCtorRenames+ = RenamedCtorOptA+ | RenamedCtorOptB (Maybe ())+ | RenamedCtorOptC Char+ deriving (Eq, Generic, Show)+ deriving (ToJSON)+ via CustomJSON+ [ ConstructorTagModifier (Rename "RenamedCtorOptA" "nullary")+ , ConstructorTagModifier (Rename "RenamedCtorOptB" "twisted-bool")+ , ConstructorTagModifier (Rename "RenamedCtorOptC" "wrapped-char")+ ] MultipleCtorRenames++data MultipleFieldRenames = MultipleFieldRenames+ { fooField1 :: Int+ , fooField2 :: Bool+ , fooField3 :: String+ }+ deriving (Eq, Generic, Show)+ deriving (ToJSON)+ via CustomJSON+ [ FieldLabelModifier (Rename "fooField1" "field-1")+ , FieldLabelModifier (Rename "fooField2" "field-2")+ , FieldLabelModifier (Rename "fooField3" "field-3")+ ] MultipleFieldRenames++main = do+ BL.putStrLn $ encode testData+ BL.putStrLn $ encode $ Foo 0 1+ BL.putStrLn $ encode $ Something 0 1++ assertEq+ (toJSON RenamedCtorOptA)+ (object [("tag", "nullary")])+ "Support multiple constructor modifiers"++ assertEq+ (toJSON $ RenamedCtorOptB Nothing)+ (object [("tag", String "twisted-bool"), ("contents", Null)])+ "Support multiple constructor modifiers"++ assertEq+ (toJSON $ RenamedCtorOptC '?')+ (object [("tag", String "wrapped-char"), ("contents", String "?")])+ "Support multiple constructor modifiers"++ assertEq+ (toJSON $ MultipleFieldRenames 42 True "meaning of life")+ (object [("field-1", Number 42)+ ,("field-2", Bool True)+ ,("field-3", String "meaning of life")+ ])+ "Support multiple field modifiers"++assertEq :: (Show a, Eq a) => a -> a -> String -> IO ()+assertEq x y expectation | x == y = pure ()+ | otherwise = die msg+ where+ msg = concat [expectation, " -- not fulfilled:\n\t", show x, "\n\t /= \n\t", show y]