deriving-aeson-0.2.10/0000755000000000000000000000000007346545000012675 5ustar0000000000000000deriving-aeson-0.2.10/CHANGELOG.md0000644000000000000000000000207607346545000014513 0ustar0000000000000000# 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. deriving-aeson-0.2.10/LICENSE0000644000000000000000000000277307346545000013713 0ustar0000000000000000Copyright Fumiaki Kinoshita (c) 2020 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Fumiaki Kinoshita nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. deriving-aeson-0.2.10/README.md0000644000000000000000000000545207346545000014162 0ustar0000000000000000deriving-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)]` * `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-0.2.10/Setup.hs0000644000000000000000000000005607346545000014332 0ustar0000000000000000import Distribution.Simple main = defaultMain deriving-aeson-0.2.10/deriving-aeson.cabal0000644000000000000000000000243207346545000016574 0ustar0000000000000000cabal-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 deriving-aeson-0.2.10/src/Deriving/0000755000000000000000000000000007346545000015233 5ustar0000000000000000deriving-aeson-0.2.10/src/Deriving/Aeson.hs0000644000000000000000000001622507346545000016642 0ustar0000000000000000{-# 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 } deriving-aeson-0.2.10/src/Deriving/Aeson/0000755000000000000000000000000007346545000016300 5ustar0000000000000000deriving-aeson-0.2.10/src/Deriving/Aeson/Stock.hs0000644000000000000000000000206207346545000017717 0ustar0000000000000000{-# 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]) deriving-aeson-0.2.10/tests/0000755000000000000000000000000007346545000014037 5ustar0000000000000000deriving-aeson-0.2.10/tests/test.hs0000644000000000000000000000543207346545000015356 0ustar0000000000000000{-# 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]