deriving-aeson 0.2.8 → 0.2.9

raw patch · 6 files changed

+477/−416 lines, 6 filesdep ~aesonPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson

API changes (from Hackage documentation)

Files

CHANGELOG.md +59/−55
README.md +73/−73
deriving-aeson.cabal +36/−36
src/Deriving/Aeson.hs +193/−192
src/Deriving/Aeson/Stock.hs +28/−28
tests/test.hs +88/−32

CHANGELOG.md view

@@ -1,55 +1,59 @@-# Revision history for deriving-aeson--## 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.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,73 @@-deriving-aeson-====--[![Hackage](https://img.shields.io/hackage/v/deriving-aeson.svg)](https://hackage.haskell.org/package/deriving-aeson)-![Haskell CI](https://github.com/fumieval/deriving-aeson/workflows/Haskell%20CI/badge.svg)-[![Discord](https://img.shields.io/discord/664807830116892674?color=%237095ec&label=Discord&style=plastic)](https://discord.gg/DG93Tgs)--![logo](https://github.com/fumieval/deriving-aeson/blob/master/logo/logo.png?raw=true)--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
+====
+
+[![Hackage](https://img.shields.io/hackage/v/deriving-aeson.svg)](https://hackage.haskell.org/package/deriving-aeson)
+![Haskell CI](https://github.com/fumieval/deriving-aeson/workflows/Haskell%20CI/badge.svg)
+[![Discord](https://img.shields.io/discord/664807830116892674?color=%237095ec&label=Discord&style=plastic)](https://discord.gg/DG93Tgs)
+
+![logo](https://github.com/fumieval/deriving-aeson/blob/master/logo/logo.png?raw=true)
+
+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.cabal view

@@ -1,36 +1,36 @@-cabal-version:       2.4-name:                deriving-aeson-version:             0.2.8-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.4, GHC == 9.2.1--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.1-  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.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

src/Deriving/Aeson.hs view

@@ -1,192 +1,193 @@-{-# 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.Aeson.Types-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 = (aesonOptions @xs) { fieldLabelModifier = getStringModifier @f }--instance (StringModifier f, AesonOptions xs) => AesonOptions (ConstructorTagModifier f ': xs) where-  aesonOptions = (aesonOptions @xs) { constructorTagModifier = 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 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 }

src/Deriving/Aeson/Stock.hs view

@@ -1,28 +1,28 @@-{-# 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
+  , 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])

tests/test.hs view

@@ -1,32 +1,88 @@-{-# LANGUAGE DerivingVia, DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-module Main where--import Data.Aeson-import Deriving.Aeson-import Deriving.Aeson.Stock-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"]--main = do-  BL.putStrLn $ encode testData-  BL.putStrLn $ encode $ Foo 0 1+{-# 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]