aeson-deriving (empty) → 0.1.0.0
raw patch · 15 files changed
+1146/−0 lines, 15 filesdep +aesondep +aeson-derivingdep +basesetup-changed
Dependencies added: aeson, aeson-deriving, base, hedgehog, text, unordered-containers
Files
- ChangeLog.md +7/−0
- LICENSE +20/−0
- README.md +94/−0
- Setup.hs +2/−0
- aeson-deriving.cabal +70/−0
- src/Data/Aeson/Deriving.hs +7/−0
- src/Data/Aeson/Deriving/Generic.hs +56/−0
- src/Data/Aeson/Deriving/Internal/Generic.hs +387/−0
- src/Data/Aeson/Deriving/Internal/RecordSum.hs +72/−0
- src/Data/Aeson/Deriving/Known.hs +82/−0
- src/Data/Aeson/Deriving/ModifyField.hs +49/−0
- src/Data/Aeson/Deriving/SingleFieldObject.hs +26/−0
- src/Data/Aeson/Deriving/Utils.hs +33/−0
- src/Data/Aeson/Deriving/WithConstantFields.hs +53/−0
- test/Main.hs +188/−0
+ ChangeLog.md view
@@ -0,0 +1,7 @@+# Changelog for aeson-deriving++## Unreleased changes++ * A newtype for encoding Aeson's generic Options type+ * A newtype for sums of records+ * A newtype for nesting the encoding under a single field
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright Cliff Harvey (c) 2019++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,94 @@+# aeson-deriving++[](https://travis-ci.org/fieldstrength/aeson-deriving)+[](http://hackage.haskell.org/package/aeson-deriving)++Define JSON encoding and decoding behavior in a unified way with [DerivingVia](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#deriving-via). This ensures the instances for the two `aeson` type classes stay in sync and eliminates much needless boilerplate, besides supporting many extra features.++## Uses and examples++### Basic encoding options & common patterns++Aeson's generics support governs the basic mapping between Haskell definitions and the JSON format.+This functionality, along with its tunable parameters, can be specified with the `GenericEncoded` newtype.++```haskell+type MyEncoding = GenericEncoded+ '[ ConstructorTagModifier := SnakeCase -- extensible function support+ , FieldLabelModifier :=+ [ SnakeCase, DropSuffix "_" ] -- functions can be composed+ , SumEncoding := TaggedObject "type" "contents"+ ]+++data User = User+ { firstName :: Text+ , id_ :: UserId + , companyId :: CompanyId+ }+ deriving stock (Generic, Show)+ deriving (FromJSON, ToJSON)+ via MyEncoding User++data Document = Document+ { name :: Text+ , id_ :: Int64+ , companyId :: CompanyId+ , parts :: [SubDocument]+ }+ deriving stock (Generic, Show)+ deriving (FromJSON, ToJSON)+ via MyEncoding Document++-- >>> encode (User "jake" 1 29)+-- { "type": "user", "first_name": "jake", "id": 1, "company_id": 29}+```++### Modifier newtypes++#### Constrant Fields++```haskell+data Transaction = Transaction+ { transactionId :: UUID }+ deriving stock (Generic, Show)+ deriving (FromJSON, ToJSON) via+ WithConstantFieldsOut+ '[ "version" := "1.0"+ , "system_info" := "👍" ]+ MyEncoding Transaction+```++Note: Some newtypes that modify the instances come in an inbound and outbound variant. For example `WithConstantFields` is defined as the composition of `WithConstantFieldsIn` and `WithConstantFieldsOut`.++#### Apply arbitrary functions before encoding/decoding++##### Example: Special treatment for magic values++```haskell++data Feedback = Feedback+ { comment :: Text }+ deriving stock (Generic, Show)+ deriving (FromJSON, ToJSON) via+ ModifyFieldIn "comment"+ ("booo!" ==> "boo-urns!")+ MyEncoding Feedback+++-- x ==> y maps the value x to y and leaves others unchanged+-- Implement your own instances of `KnownJSONFunction` for other behavior++```++### Preventing infinite loops++Newtypes that modify an inner type class instance must be careful not to do so in an infinitely recursive way. Here the inner type should use the generic-based instance, rather than reference the instance being defined.++This package employs a custom compiler error to prevent this very easy mistake.++### Improved error messages for sums of records++See `RecordSumEncoded` documentation.++To be expanded...
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ aeson-deriving.cabal view
@@ -0,0 +1,70 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: bd8e2b4289bac4670675ad3e5d5307767ea3ad1d4a053a709b95767944b84df0++name: aeson-deriving+version: 0.1.0.0+synopsis: data types for compositional, type-directed serialization+description: Please see the README on GitHub at <https://github.com/fieldstrength/aeson-deriving#readme>+category: Serialization+homepage: https://github.com/fieldstrength/aeson-deriving#readme+bug-reports: https://github.com/fieldstrength/aeson-deriving/issues+author: Cliff Harvey+maintainer: cs.hbar+hs@gmail.com+copyright: 2020+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/fieldstrength/aeson-deriving++library+ exposed-modules:+ Data.Aeson.Deriving+ Data.Aeson.Deriving.Internal.Generic+ Data.Aeson.Deriving.Internal.RecordSum+ Data.Aeson.Deriving.Generic+ Data.Aeson.Deriving.Known+ Data.Aeson.Deriving.ModifyField+ Data.Aeson.Deriving.SingleFieldObject+ Data.Aeson.Deriving.Utils+ Data.Aeson.Deriving.WithConstantFields+ other-modules:+ Paths_aeson_deriving+ hs-source-dirs:+ src+ default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveGeneric DerivingStrategies FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings ScopedTypeVariables TupleSections TypeApplications TypeOperators+ ghc-options: -Wall -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns+ build-depends:+ aeson >=1.2 && <1.5+ , base >=4.7 && <5+ , text+ , unordered-containers+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Paths_aeson_deriving+ hs-source-dirs:+ test+ default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveGeneric DerivingStrategies FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings ScopedTypeVariables TupleSections TypeApplications TypeOperators+ ghc-options: -Wall -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns+ build-depends:+ aeson >=1.2 && <1.5+ , aeson-deriving+ , base >=4.7 && <5+ , hedgehog+ , text+ , unordered-containers+ default-language: Haskell2010
+ src/Data/Aeson/Deriving.hs view
@@ -0,0 +1,7 @@+module Data.Aeson.Deriving (module AllExports) where++import Data.Aeson.Deriving.Generic as AllExports+import Data.Aeson.Deriving.Known as AllExports+import Data.Aeson.Deriving.ModifyField as AllExports+import Data.Aeson.Deriving.SingleFieldObject as AllExports+import Data.Aeson.Deriving.WithConstantFields as AllExports
+ src/Data/Aeson/Deriving/Generic.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Aeson.Deriving.Generic+ ( -- * Typeclass for aeson 'Options'+ ToAesonOptions(..)+ -- * newtypes for Generic encodings+ -- ** Main data type for Generic encodings+ , GenericEncoded(..)+ -- ** Data type for encodings of composite "sum-of-records" types+ , RecordSumEncoded(..)+ -- * Phantom types for specifying Options+ -- ** Many-parameter type for explicitly providing all 'Options' fields.+ , GenericOptions+ -- ** Types for supplying specific Options fields+ -- *** Type representing field assignment+ , (:=)+ -- *** Typeclass for Options fields+ , ToAesonOptionsField+ -- *** Types representing Options fields+ , FieldLabelModifier+ , ConstructorTagModifier+ , AllNullaryToStringTag+ , OmitNothingFields+ , SumEncoding -- technically an aeson reexport. Shouldn't matter.+ , UnwrapUnaryRecords+ , TagSingleConstructors+ -- *** String Functions+ , StringFunction(..)+ , SnakeCase+ , Uppercase+ , Lowercase+ , DropLowercasePrefix+ , DropPrefix+ , DropSuffix+ , Id+ , snakeCase+ , dropLowercasePrefix+ -- *** Sum encoding options+ , ToSumEncoding+ , UntaggedValue+ , ObjectWithSingleField+ , TwoElemArray+ , TaggedObject+ -- * Safety class+ , LoopWarning+ , DisableLoopWarning(..)+ -- * Convenience newtype+ , type (&) (Ampersand)+ , unAmpersand+ ) where++import Data.Aeson+import Data.Aeson.Deriving.Internal.Generic+import Data.Aeson.Deriving.Known
+ src/Data/Aeson/Deriving/Internal/Generic.hs view
@@ -0,0 +1,387 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Aeson.Deriving.Internal.Generic where++import Data.Aeson+import Data.Aeson.Deriving.Known+import Data.Aeson.Deriving.Internal.RecordSum+import Data.Aeson.Deriving.Utils+import Data.Aeson.Types (modifyFailure)+import Data.Char (isUpper, toLower, toUpper)+import Data.Function ((&))+import qualified Data.HashMap.Strict as HashMap+import Data.Kind (Constraint, Type)+import Data.List (intercalate, stripPrefix)+import Data.Maybe (fromMaybe)+import Data.Proxy (Proxy (..))+import Data.Text (pack)+import GHC.Generics+import GHC.TypeLits++------------------------------------------------------------------------------------------+-- Main class+------------------------------------------------------------------------------------------++-- | A class for defining 'Options' for Aeson's Generic deriving support.+-- It is generally instantiated by overriding specific fields using the instance+-- for (type-level) list values. It can also be instantiated in a more exhaustive way+-- using the 'GenericOptions' type. In both cases fields are specified in a record-like+-- form using the '(:=)' data type for explicitness.+--+-- See the ReadMe or tests for examples.+--+-- Users may also provide instances for their own phantom data types if desired.+class ToAesonOptions a where+ toAesonOptions :: Proxy a -> Options++instance ToAesonOptions '[] where toAesonOptions Proxy = defaultOptions+instance (ToAesonOptionsField x, ToAesonOptions xs) => ToAesonOptions (x ': xs) where+ toAesonOptions Proxy =+ let+ patch = toAesonOptionsField (Proxy @x)+ opts = toAesonOptions (Proxy @xs)+ in+ patch $ defaultOptions+ { fieldLabelModifier = fieldLabelModifier opts+ , constructorTagModifier = constructorTagModifier opts+ , allNullaryToStringTag = allNullaryToStringTag opts+ , omitNothingFields = omitNothingFields opts+ , sumEncoding = sumEncoding opts+ , unwrapUnaryRecords = unwrapUnaryRecords opts+ , tagSingleConstructors = tagSingleConstructors opts+ }++-- Its easy to get confusing errors if you forget to tick the list syntax. Hence the custom error+instance TypeError ToAesonOptionsListError => ToAesonOptions [] where toAesonOptions = undefined+instance TypeError ToAesonOptionsListError => ToAesonOptions [a] where toAesonOptions = undefined++type ToAesonOptionsListError =+ ( 'Text "aeson-deriving constraint error for ToAesonOptions class:"+ ':$$: 'Text "Don't forget to \"tick\" your opening list bracket."+ ':$$: 'Text "There is no ToAesonOptions instance for list types."+ ':$$: 'Text "Rather, there are instances for promoted list values."+ ':$$: 'Text ""+ ':$$: 'Text "You likely should correct your deriving declaration to something like:"+ ':$$: 'Text ""+ ':$$: 'Text " via GenericEncoded '[myVal1,..]"+ ':$$: 'Text ""+ ':$$: 'Text "Instead of:"+ ':$$: 'Text ""+ ':$$: 'Text " via GenericEncoded [myVal1,..]"+ ':$$: 'Text ""+ ':$$: 'Text "For explanation, see GHC documentation on datatype promotion:"+ ':$$: 'Text "https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#datatype-promotion"+ ':$$: 'Text ""+ )++-- | A class that knows about fields of aeson's 'Options'.+class ToAesonOptionsField x where+ toAesonOptionsField :: Proxy x -> Options -> Options++-- | Represents an aeson 'Options' field to be set with `(:=)`. See `ToAesonOptions`+data FieldLabelModifier+-- | Represents an aeson 'Options' field to be set with `(:=)`. See `ToAesonOptions`+data ConstructorTagModifier+-- | Represents an aeson 'Options' field to be set with `(:=)`. See `ToAesonOptions`+data AllNullaryToStringTag+-- | Represents an aeson 'Options' field to be set with `(:=)`. See `ToAesonOptions`+data OmitNothingFields++-- SumEncoding type name already exists in aeson. We repurpose it.++-- | Represents an aeson 'Options' field to be set with `(:=)`. See `ToAesonOptions`+data UnwrapUnaryRecords+-- | Represents an aeson 'Options' field to be set with `(:=)`. See `ToAesonOptions`+data TagSingleConstructors++instance StringFunction f => ToAesonOptionsField (FieldLabelModifier := f) where+ toAesonOptionsField Proxy opts = opts {fieldLabelModifier = stringFunction $ Proxy @f}+instance StringFunction f => ToAesonOptionsField (ConstructorTagModifier := f) where+ toAesonOptionsField Proxy opts = opts {constructorTagModifier = stringFunction $ Proxy @f}+instance KnownBool b => ToAesonOptionsField (AllNullaryToStringTag := b) where+ toAesonOptionsField Proxy opts = opts {allNullaryToStringTag = boolVal $ Proxy @b}+instance KnownBool b => ToAesonOptionsField (OmitNothingFields := b) where+ toAesonOptionsField Proxy opts = opts {omitNothingFields = boolVal $ Proxy @b}+instance ToSumEncoding se => ToAesonOptionsField (SumEncoding := se) where+ toAesonOptionsField Proxy opts = opts {sumEncoding = toSumEncoding $ Proxy @se}+instance KnownBool b => ToAesonOptionsField (UnwrapUnaryRecords := b) where+ toAesonOptionsField Proxy opts = opts {unwrapUnaryRecords = boolVal $ Proxy @b}+instance KnownBool b => ToAesonOptionsField (TagSingleConstructors := b) where+ toAesonOptionsField Proxy opts = opts {tagSingleConstructors = boolVal $ Proxy @b}+++------------------------------------------------------------------------------------------+-- A Single type for all Options fields+------------------------------------------------------------------------------------------++-- | Type-level representation of the Aeson Generic deriving 'Options'.+-- This representation is useful for explicitly setting all options.+data GenericOptions+ :: fieldLabelModifier+ -> constructorTagModifier+ -> allNullaryToStringTag+ -> omitNothingFields+ -> sumEncoding+ -> unwrapUnaryRecords+ -> tagSingleConstructors+ -> Type++instance+ ( All StringFunction [fieldLabelModifier, constructorTagModifier]+ , ToSumEncoding sumEncoding+ , All KnownBool+ [ allNullaryToStringTag+ , omitNothingFields+ , unwrapUnaryRecords+ , tagSingleConstructors+ ]+ ) => ToAesonOptions+ (GenericOptions+ (FieldLabelModifier := fieldLabelModifier)+ (ConstructorTagModifier := constructorTagModifier)+ (AllNullaryToStringTag := allNullaryToStringTag)+ (OmitNothingFields := omitNothingFields)+ (SumEncoding := sumEncoding)+ (UnwrapUnaryRecords := unwrapUnaryRecords)+ (TagSingleConstructors := tagSingleConstructors)) where+ toAesonOptions _ = defaultOptions+ { fieldLabelModifier = stringFunction $ Proxy @fieldLabelModifier+ , constructorTagModifier = stringFunction $ Proxy @constructorTagModifier+ , allNullaryToStringTag = boolVal $ Proxy @allNullaryToStringTag+ , omitNothingFields = boolVal $ Proxy @omitNothingFields+ , sumEncoding = toSumEncoding $ Proxy @sumEncoding+ , unwrapUnaryRecords = boolVal $ Proxy @unwrapUnaryRecords+ , tagSingleConstructors = boolVal $ Proxy @tagSingleConstructors+ }++++-- | Specify your encoding scheme in terms of aeson's out-of-the box Generic+-- functionality. This type is never used directly, only "coerced through".+-- Use some of the pre-defined types supplied here for the @opts@ phantom parameter,+-- or define your with an instance of 'ToAesonOptions'.+newtype GenericEncoded opts a = GenericEncoded a++instance+ ( ToAesonOptions opts+ , Generic a+ , GFromJSON Zero (Rep a))+ => FromJSON (GenericEncoded opts a) where+ parseJSON = fmap GenericEncoded . genericParseJSON (toAesonOptions $ Proxy @opts)++instance+ ( ToAesonOptions opts+ , Generic a+ , GToJSON Zero (Rep a))+ => ToJSON (GenericEncoded opts a) where+ toJSON (GenericEncoded x)+ = genericToJSON (toAesonOptions (Proxy @opts)) x++-- | Used in FromJSON/ToJSON superclass constraints for newtypes that recursively modify+-- the instances. A guard against the common mistake of deriving encoders in terms+-- of such a newtype over the naked base type instead of the 'GenericEncoded' version.+-- This can lead to nasty runtime bugs.+--+-- This error can be disabled by wrapping your type in 'DisableLoopWarning'.+-- This should never be necessary to use the functionality of this package. It may be+-- required if you, for example, combine our newtypes with another library's types+-- for generating aeson instances.+type family LoopWarning (n :: Type -> Type) (a :: Type) :: Constraint where+ LoopWarning n (GenericEncoded opts a) = ()+ LoopWarning n (RecordSumEncoded tagKey tagValMod a) = ()+ LoopWarning n (DisableLoopWarning a) = ()+ LoopWarning n (x & f) = LoopWarning n (f x)+ LoopWarning n (f x) = LoopWarning n x+ LoopWarning n x = TypeError+ ( 'Text "Uh oh! Watch out for those infinite loops!"+ ':$$: 'Text "Newtypes that recursively modify aeson instances, namely:"+ ':$$: 'Text ""+ ':$$: 'Text " " ':<>: 'ShowType n+ ':$$: 'Text ""+ ':$$: 'Text "must only be used atop a type that creates the instances non-recursively: "+ ':$$: 'Text ""+ ':$$: 'Text " ￮ GenericEncoded"+ ':$$: 'Text " ￮ RecordSumEncoded"+ ':$$: 'Text ""+ ':$$: 'Text "We observe instead the inner type: "+ ':$$: 'Text ""+ ':$$: 'Text " " ':<>: 'ShowType x+ ':$$: 'Text ""+ ':$$: 'Text "You probably created an infinitely recursive encoder/decoder pair."+ ':$$: 'Text "See `LoopWarning` for details."+ ':$$: 'Text "This check can be disabled by wrapping the inner type in `DisableLoopWarning`."+ ':$$: 'Text ""+ )++-- | Assert that you know what you're doing and to nullify the 'LoopWarning' constraint+-- family. This should not be necessary.+newtype DisableLoopWarning a = DisableLoopWarning a+ deriving newtype (FromJSON, ToJSON)++------------------------------------------------------------------------------------------+-- Sums over records+------------------------------------------------------------------------------------------++-- | An encoding scheme for sums of records that are defined as distinct data types.+-- If we have a number of record types we want to combine under a sum, a straightforward+-- solution is to ensure that each each inner type uses a constructor tag, and then+-- derive the sum with @SumEncoding := UntaggedValue@. This works fine for the happy+-- path, but makes for very bad error messages, since it means that decoding proceeds by+-- trying each case in sequence. Thus error messages always pertain to the last type in+-- the sum, even when it wasn't the intended payload. This newtype improves on that+-- solution by providing the relevant error messages, by remembering the correspondence+-- between the constructor tag and the intended inner type/parser.+--+-- In order to work correctly, the inner types must use the 'TaggedObject' encoding.+-- The same tag field name and 'ConstructorTagModifier' must be supplied to this type.+newtype RecordSumEncoded (tagKey :: Symbol) (tagModifier :: k) (a :: Type) = RecordSumEncoded a++instance+ ( Generic a+ , GFromJSON Zero (Rep a)+ , GTagParserMap (Rep a)+ , Rep a ~ D1 meta cs+ , Datatype meta+ , StringFunction tagModifier+ , KnownSymbol tagKey)+ => FromJSON (RecordSumEncoded tagKey tagModifier a) where+ parseJSON val = prependErrMsg outerErrorMsg . flip (withObject "Object") val $ \hm -> do+ tagVal <- hm .: pack tagKeyStr+ case HashMap.lookup tagVal parserMap of+ Nothing -> fail . mconcat $+ [ "We are not expecting a payload with tag value " <> backticks tagVal+ , " under the " <> backticks tagKeyStr <> " key here. "+ , "Expected tag values: "+ , intercalate ", " $ backticks <$> HashMap.keys parserMap+ , "."+ ]+ Just parser -> RecordSumEncoded . to <$> parser val+ & prependErrMsg+ ("Failed parsing the case with tag value "+ <> backticks tagVal <> " under the "+ <> backticks tagKeyStr <> " key: ")++ where+ tagKeyStr = symbolVal $ Proxy @tagKey+ ParserMap parserMap+ = unsafeMapKeys (stringFunction $ Proxy @tagModifier)+ . gParserMap+ $ Proxy @(Rep a)+ backticks str = "`" <> str <> "`"+ prependErrMsg str = modifyFailure (str <>)+ outerErrorMsg = "Failed to parse a " <> datatypeName @meta undefined <> ": "+++instance+ ( Generic a+ , GToJSON Zero (Rep a))+ => ToJSON (RecordSumEncoded tagKey tagModifier a) where+ toJSON (RecordSumEncoded x) =+ toJSON $ GenericEncoded @'[SumEncoding := UntaggedValue] x++++------------------------------------------------------------------------------------------+-- String functions+------------------------------------------------------------------------------------------++stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]+stripSuffix a b = reverse <$> stripPrefix (reverse a) (reverse b)++dropPrefix :: Eq a => [a] -> [a] -> [a]+dropPrefix a b = fromMaybe b $ stripPrefix a b++dropSuffix :: Eq a => [a] -> [a] -> [a]+dropSuffix a b = fromMaybe b $ stripSuffix a b++class StringFunction (a :: k) where+ stringFunction :: Proxy a -> String -> String++data Id+-- | Applies 'snakeCase'+data SnakeCase+data Uppercase+data Lowercase+-- | Applies 'dropLowercasePrefix', dropping until the first uppercase character.+data DropLowercasePrefix+data DropPrefix (str :: Symbol)+data DropSuffix (str :: Symbol)++instance StringFunction Id where stringFunction _ = id+instance StringFunction SnakeCase where stringFunction _ = snakeCase+instance StringFunction Uppercase where stringFunction _ = map toUpper+instance StringFunction Lowercase where stringFunction _ = map toLower+instance StringFunction DropLowercasePrefix where stringFunction _ = dropLowercasePrefix++instance KnownSymbol str => StringFunction (DropPrefix str) where+ stringFunction Proxy = dropPrefix (symbolVal $ Proxy @str)+instance KnownSymbol str => StringFunction (DropSuffix str) where+ stringFunction Proxy = dropSuffix (symbolVal $ Proxy @str)++instance StringFunction '[] where stringFunction _ = id+instance (StringFunction x, StringFunction xs) => StringFunction (x ': xs) where+ stringFunction Proxy = stringFunction (Proxy @x) . stringFunction (Proxy @xs)++instance All KnownSymbol [a, b] => StringFunction (a ==> b) where+ stringFunction Proxy x+ | x == symbolVal (Proxy @a) = symbolVal (Proxy @b)+ | otherwise = x++------------------------------------------------------------------------------------------+-- Sum type encodings+------------------------------------------------------------------------------------------++-- | Type-level encoding for 'SumEncoding'+class ToSumEncoding a where+ toSumEncoding :: Proxy a -> SumEncoding++data UntaggedValue+data ObjectWithSingleField+data TwoElemArray++-- | A constructor will be encoded to an object with a field tagFieldName which specifies+-- the constructor tag (modified by the constructorTagModifier). If the constructor is+-- a record the encoded record fields will be unpacked into this object. So make sure+-- that your record doesn't have a field with the same label as the tagFieldName.+-- Otherwise the tag gets overwritten by the encoded value of that field! If the+-- constructor is not a record the encoded constructor contents will be stored under+-- the contentsFieldName field.+data TaggedObject (tagFieldName :: Symbol) (contentsFieldName :: Symbol)+-- Would be nice to have separate types for records versus ordinary constructors+-- rather than conflating them with the conditional interpretation of this type.+-- However, this module is just about modeling what aeson gives us.++instance ToSumEncoding UntaggedValue where toSumEncoding _ = UntaggedValue+instance ToSumEncoding ObjectWithSingleField where toSumEncoding _ = ObjectWithSingleField+instance ToSumEncoding TwoElemArray where toSumEncoding _ = TwoElemArray+instance (KnownSymbol tag, KnownSymbol contents) => ToSumEncoding (TaggedObject tag contents) where+ toSumEncoding _ = TaggedObject+ (symbolVal $ Proxy @tag)+ (symbolVal $ Proxy @contents)+++------------------------------------------------------------------------------------------+-- Utilities+------------------------------------------------------------------------------------------++-- | Field name modifier function that separates camel-case words by underscores+-- (i.e. on capital letters). Also knows to handle a consecutive sequence of+-- capitals as a single word.+snakeCase :: String -> String+snakeCase = camelTo2 '_'++-- | Drop the first lowercase sequence (i.e. until 'isUpper' returns True) from the start+-- of a string. Used for the common idiom where fields are prefixed by the type name in+-- all lowercase. The definition is taken from the aeson-casing package.+dropLowercasePrefix :: String -> String+dropLowercasePrefix [] = []+dropLowercasePrefix (x:xs)+ | isUpper x = x : xs+ | otherwise = dropLowercasePrefix xs++infixl 2 &++newtype (x & f) = Ampersand {unAmpersand :: f x }+ deriving newtype (FromJSON, ToJSON)
+ src/Data/Aeson/Deriving/Internal/RecordSum.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE UndecidableInstances #-}++module Data.Aeson.Deriving.Internal.RecordSum where++import Data.Aeson+import Data.Aeson.Types (Parser)+import Data.Bifunctor (first)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Kind (Type)+import Data.Proxy+import GHC.Generics+++newtype ParserMap a = ParserMap (HashMap String (Value -> Parser a))+ deriving stock Functor+ deriving newtype (Semigroup, Monoid)++unsafeMapKeys :: (String -> String) -> ParserMap a -> ParserMap a+unsafeMapKeys f (ParserMap hm)+ = ParserMap+ . HashMap.fromList+ . fmap (first f)+ $ HashMap.toList hm++-- | Provides a map from the (Haskell) constructor names of the inner contained types,+-- To parsers for the (Rep of the) outer data type that carries them.+class GTagParserMap (repA :: Type -> Type) where+ gParserMap :: Proxy repA -> ParserMap (repA x)++-- | We can create a ParserMap from any reference to a data type that has a+-- FromJSON instance (and at least one available constructor).+instance (GConstructorNames (Rep a), FromJSON a) => GTagParserMap (Rec0 a) where+ gParserMap _ = ParserMap . HashMap.fromList $ do+ constructorName <- gConstructorNames $ Proxy @(Rep a)+ [(constructorName, fmap K1 . parseJSON)]++-- | ParserMaps are trivially extended to the representation of fields under a constructor+instance GTagParserMap repA => GTagParserMap (S1 meta repA) where+ gParserMap _ = M1 <$> gParserMap (Proxy @repA)++-- | ParserMaps are extended to the canonical representation of a constructor.+-- Because there is no instance for :*:, this constraint is only satisfied for types+-- with a single constructor (with an S1 Directly under the C1 in the canonical rep).+instance GTagParserMap repA => GTagParserMap (C1 meta repA) where+ gParserMap _ = M1 <$> gParserMap (Proxy @repA)++-- | ParserMaps corresponding to different cases of a sum type are combined by merging.+instance (GTagParserMap repA, GTagParserMap repB) => GTagParserMap (repA :+: repB) where+ gParserMap _ =+ (L1 <$> gParserMap (Proxy @repA))+ <> (R1 <$> gParserMap (Proxy @repB))++-- | The ParserMap for the whole data type is now the one we get from under this D1 constructor.+instance GTagParserMap repA => GTagParserMap (D1 meta repA) where+ gParserMap _ = M1 <$> gParserMap (Proxy @repA)+++-- | Provides constructor names+class GConstructorNames (repA :: Type -> Type) where+ gConstructorNames :: Proxy repA -> [String]++instance Constructor constructorMeta => GConstructorNames (C1 constructorMeta r) where+ gConstructorNames _ = [conName @constructorMeta undefined]++instance (GConstructorNames x, GConstructorNames y) => GConstructorNames (x :+: y) where+ gConstructorNames _ =+ gConstructorNames (Proxy @x)+ <> gConstructorNames (Proxy @y)++instance GConstructorNames r => GConstructorNames (D1 datatypeMeta r) where+ gConstructorNames _ = gConstructorNames $ Proxy @r
+ src/Data/Aeson/Deriving/Known.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Aeson.Deriving.Known where++import Data.Aeson+import qualified Data.HashMap.Strict as HashMap+import Data.Kind (Type)+import Data.Proxy+import Data.Text (pack)+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+++infix 3 :=+infix 6 ==>+++-- | Represents the null JSON 'Value'.+data Null++-- | Phantom data type to make explicit which fields we pass for Aeson options. Polykinded+-- in the second argument so it can take i.e. Booleans or Symbols where needed.+--+-- Also used for specifying constant values added to, or required from, an encoding.+-- See "Data.Aeson.Deriving.WithConstantFields".+data field := (value :: k)++-- | Represents a function that maps the first value to the second,+-- and otherwise does nothing but return the input.+data a ==> b++-- | Represents the function that turns nulls into the given default value.+data WithDefault (val :: k)++-- | Constant JSON values+class KnownJSON (a :: k) where jsonVal :: Proxy a -> Value++instance KnownSymbol str => KnownJSON (str :: Symbol) where jsonVal = String . pack . symbolVal+instance KnownBool b => KnownJSON (b :: Bool) where jsonVal = Bool . boolVal+instance KnownJSON Null where jsonVal Proxy = Null+instance KnownJSONList (xs :: [k]) => KnownJSON xs where jsonVal Proxy = toJSON $ listVal (Proxy @xs)++-- | Constant boolean values+class KnownBool (b :: Bool) where boolVal :: Proxy b -> Bool++instance KnownBool 'True where boolVal Proxy = True+instance KnownBool 'False where boolVal Proxy = False++-- | Constant JSON lists+class KnownJSONList (xs :: [k]) where listVal :: Proxy xs -> [Value]++instance KnownJSONList '[] where listVal Proxy = []+instance (KnownJSON x, KnownJSONList xs) => KnownJSONList (x ': xs) where+ listVal Proxy = jsonVal (Proxy @x) : listVal (Proxy @xs)+++-- | Constant JSON objects+class KnownJSONObject (a :: k) where objectVal :: Proxy a -> Object++instance KnownJSONObject '[] where objectVal Proxy = mempty+instance (KnownJSONObject fields, KnownSymbol key, KnownJSON val)+ => KnownJSONObject ((key := val) ': fields) where+ objectVal Proxy =+ HashMap.insert+ (pack . symbolVal $ Proxy @key)+ (jsonVal $ Proxy @val)+ (objectVal $ Proxy @fields)+++-- | JSON ('Value') functions+class KnownJSONFunction (a :: Type) where functionVal :: Proxy a -> Value -> Value++-- instance All KnownJSON [a, b] => KnownJSONFunction (a ==> b) where+instance (KnownJSON a, KnownJSON b) => KnownJSONFunction (a ==> b) where+ functionVal Proxy x+ | x == jsonVal (Proxy @a) = jsonVal (Proxy @b)+ | otherwise = x++instance KnownJSON a => KnownJSONFunction (WithDefault a) where+ functionVal Proxy = \case+ Null -> jsonVal $ Proxy @a+ x -> x
+ src/Data/Aeson/Deriving/ModifyField.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Aeson.Deriving.ModifyField where++import Data.Aeson+import Data.Aeson.Deriving.Generic+import Data.Aeson.Deriving.Known+import Data.Aeson.Deriving.Utils+import Data.Proxy+import GHC.Generics+import GHC.TypeLits (KnownSymbol, Symbol)++-- | Modify the contents of a particular field while decoding.+newtype ModifyFieldIn (fieldName :: Symbol) fun a = ModifyFieldIn a+ deriving stock Generic+ deriving ToJSON via a++instance+ ( FromJSON a+ , KnownSymbol fieldName+ , KnownJSONFunction fun+ , LoopWarning (ModifyFieldIn fieldName fun) a)+ => FromJSON (ModifyFieldIn fieldName fun a) where+ parseJSON+ = fmap ModifyFieldIn+ . parseJSON @a+ . mapObjects (mapField (textVal $ Proxy @fieldName) (functionVal $ Proxy @fun))++-- | Modify the contents of a particular field while encoding.+newtype ModifyFieldOut (fieldName :: Symbol) fun a = ModifyFieldOut a+ deriving stock Generic+ deriving FromJSON via a++instance+ ( ToJSON a+ , KnownSymbol fieldName+ , KnownJSONFunction fun+ , LoopWarning (ModifyFieldOut fieldName fun) a)+ => ToJSON (ModifyFieldOut fieldName fun a) where+ toJSON (ModifyFieldOut x)+ = mapObjects (mapField (textVal $ Proxy @fieldName) (functionVal $ Proxy @fun))+ $ toJSON x++newtype RemapTextField fieldName haskVal jsonVal a = RemapTextField+ (ModifyFieldOut fieldName (haskVal ==> jsonVal)+ (ModifyFieldIn fieldName (jsonVal ==> haskVal) a))+ deriving newtype (FromJSON, ToJSON)
+ src/Data/Aeson/Deriving/SingleFieldObject.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE UndecidableInstances #-}++module Data.Aeson.Deriving.SingleFieldObject where++import Data.Aeson+import Data.Aeson.Deriving.Generic (LoopWarning)+import Data.Proxy+import Data.Text (pack)+import GHC.Generics+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)++-- | Puts the entire output of encoding the inner type within a single field+newtype SingleFieldObject (fieldName :: Symbol) a = SingleFieldObject a+ deriving stock (Generic)++instance (ToJSON a, LoopWarning (SingleFieldObject fieldName) a, KnownSymbol fieldName) =>+ ToJSON (SingleFieldObject fieldName a) where+ toJSON (SingleFieldObject a) = object+ [ ( pack . symbolVal $ Proxy @fieldName+ , toJSON a+ )+ ]++instance (FromJSON a, LoopWarning (SingleFieldObject fieldName) a, KnownSymbol fieldName) => FromJSON (SingleFieldObject fieldName a) where+ parseJSON = withObject "Object" $ \hm ->+ SingleFieldObject <$> hm .: (pack . symbolVal $ Proxy @fieldName)
+ src/Data/Aeson/Deriving/Utils.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Aeson.Deriving.Utils+ ( mapObjects+ , mapField+ , All+ , textVal+ ) where++import Data.Aeson+import qualified Data.HashMap.Strict as HashMap+import Data.Kind (Constraint)+import Data.Proxy+import Data.Text+import GHC.TypeLits++mapObjects :: (Object -> Object) -> Value -> Value+mapObjects f (Object o) = Object (f o)+mapObjects _ val = val++mapField :: Text -> (Value -> Value) -> Object -> Object+mapField str f = HashMap.mapWithKey $ \s x ->+ if s == str then f x else x++-- | Convenience constraint family. All @types@ in the list satisfy the @predicate@.+type family All (predicate :: k -> Constraint) (types :: [k]) :: Constraint where+ All predicate '[] = ()+ All predicate (t ': ts) = (predicate t, All predicate ts)+++textVal :: KnownSymbol s => Proxy s -> Text+textVal = pack . symbolVal
+ src/Data/Aeson/Deriving/WithConstantFields.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Aeson.Deriving.WithConstantFields where++import Control.Monad (unless)+import Data.Aeson+import Data.Aeson.Deriving.Generic+import Data.Aeson.Deriving.Known+import Data.Aeson.Deriving.Utils+import qualified Data.HashMap.Strict as HashMap+import Data.Kind (Type)+import Data.Proxy+import GHC.Generics++-- | Add arbitrary constant fields to the encoded object and require them when decoding.+newtype WithConstantFields (obj :: k) (a :: Type) = WithConstantFields a+ deriving stock (Generic)++-- | Add arbitrary constant fields to the encoded object, but do not require them when+-- decoding.+newtype WithConstantFieldsOut (obj :: k) (a :: Type) = WithConstantFieldsOut a+ deriving stock (Generic)+ deriving ToJSON via (WithConstantFields obj a)+ deriving FromJSON via a++-- | Require arbitrary constant fields when decoding the object, but do not add them when+-- encoding.+newtype WithConstantFieldsIn (obj :: k) (a :: Type) = WithConstantFieldsIn a+ deriving stock (Generic)+ deriving ToJSON via a+ deriving FromJSON via (WithConstantFields obj a)+++instance (ToJSON a, LoopWarning (WithConstantFields obj) a, KnownJSONObject obj) =>+ ToJSON (WithConstantFields obj a) where+ toJSON (WithConstantFields x) = mapObjects (<> fields) $ toJSON x+ where+ fields = objectVal $ Proxy @obj++instance (FromJSON a, LoopWarning (WithConstantFields obj) a, KnownJSONObject obj) => FromJSON (WithConstantFields obj a) where+ parseJSON valIn = WithConstantFields <$>+ parseJSON valIn <*+ HashMap.traverseWithKey assertFieldPresent (objectVal $ Proxy @obj)++ where+ assertFieldPresent key valExpected =+ flip (withObject "Object") valIn $ \obj -> do+ valActual <- obj .: key+ unless (valActual == valExpected) . fail $+ "Expected constant value `" <> show valExpected <> "` but got: " <>+ show valActual
+ test/Main.hs view
@@ -0,0 +1,188 @@+{-# Language DerivingVia #-}+{-# Language DataKinds #-}+{-# Language TemplateHaskell #-}+{-# Language DeriveAnyClass #-}+{-# Language DuplicateRecordFields #-}++module Main where++import Data.Aeson+import Data.Aeson.Deriving+import GHC.Generics+import Hedgehog+import Hedgehog.Main (defaultMain)++main :: IO ()+main = defaultMain [checkParallel $$(discover)]++type IdiomaticEncoded =+ GenericEncoded '[FieldLabelModifier := '[SnakeCase, DropLowercasePrefix]]++data Dog = Dog+ { dogAgeInDogYears :: Int+ , dogName :: String+ }+ deriving stock (Generic, Show, Eq)+ deriving (ToJSON, FromJSON) via IdiomaticEncoded Dog++once :: Property -> Property+once = withTests 1++prop_fido_encodes_as_expected :: Property+prop_fido_encodes_as_expected = once . property $+ encode (Dog 9 "fido") === "{\"name\":\"fido\",\"age_in_dog_years\":9}"++prop_fido_decodes_as_expected :: Property+prop_fido_decodes_as_expected = once . property $+ tripping (Dog 9 "fido") encode eitherDecode+++type UppercaseTypeTagEncoded =+ GenericEncoded+ '[ FieldLabelModifier := '[SnakeCase, DropLowercasePrefix]+ , SumEncoding := TaggedObject "type" "contents"+ , TagSingleConstructors := 'True+ , ConstructorTagModifier := '[Uppercase, SnakeCase]+ ]++data PostArticle = PostArticle+ { articleName :: String+ , articleText :: String+ }+ deriving stock (Generic, Show, Eq)+ deriving (ToJSON, FromJSON) via UppercaseTypeTagEncoded PostArticle++data DeleteArticle = DeleteArticle+ { articleId :: Int+ }+ deriving stock (Generic, Show, Eq)+ deriving (ToJSON, FromJSON) via UppercaseTypeTagEncoded DeleteArticle++data ArticleCommand+ = MkPostArticle PostArticle+ | MkDeleteArticle DeleteArticle+ deriving stock (Generic, Show, Eq)+ deriving (ToJSON, FromJSON) via RecordSumEncoded "type" '[Uppercase, SnakeCase] ArticleCommand++prop_record_sum_encodes_as_expected :: Property+prop_record_sum_encodes_as_expected = once . property $+ encode (MkDeleteArticle $ DeleteArticle 9)+ === "{\"id\":9,\"type\":\"DELETE_ARTICLE\"}"++prop_record_sum_decodes_as_expected :: Property+prop_record_sum_decodes_as_expected = once . property $+ tripping (MkDeleteArticle $ DeleteArticle 9) encode decode+++data MyVal+instance KnownJSON MyVal where jsonVal _ = Number 1++data X = X {xval :: Int}+ deriving stock (Generic, Show, Eq)+ deriving (FromJSON, ToJSON) via+ X+ & GenericEncoded '[]+ & WithConstantFields+ '["bar" := "baaz", "quux" := MyVal, "arr" := ["Hilbert","Dirac"]]++prop_WithConstantFields_extra_fields_encode_as_expected :: Property+prop_WithConstantFields_extra_fields_encode_as_expected = once . property $+ encode (X 9)+ === "{\"xval\":9,\"arr\":[\"Hilbert\",\"Dirac\"],\"quux\":1,\"bar\":\"baaz\"}"++prop_WithConstantFields_extra_fields_decode_as_expected :: Property+prop_WithConstantFields_extra_fields_decode_as_expected = once . property $+ tripping (X 9) encode decode++prop_WithConstantFields_extra_fields_required_when_decoding :: Property+prop_WithConstantFields_extra_fields_required_when_decoding = once . property $+ decode @X "{\"xval\":9}" === Nothing++data X2 = X2 {xval :: Int}+ deriving stock (Generic, Show, Eq)+ deriving (FromJSON, ToJSON) via+ WithConstantFieldsOut+ '["bar" := "baaz", "quux" := "axion"]+ (GenericEncoded '[] X2)++prop_WithConstantFieldsOut_encodes_as_expected :: Property+prop_WithConstantFieldsOut_encodes_as_expected = once . property $+ encode (X2 9)+ === "{\"xval\":9,\"quux\":\"axion\",\"bar\":\"baaz\"}"++prop_WithConstantFieldsOut_extra_fields_not_required_when_decoding :: Property+prop_WithConstantFieldsOut_extra_fields_not_required_when_decoding = once . property $+ decode @X2 "{\"xval\":9}" === Just (X2 9)++data X3 = X3 {xval :: Int}+ deriving stock (Generic, Show, Eq)+ deriving (FromJSON, ToJSON) via+ WithConstantFieldsIn+ '["bar" := "baaz", "quux" := "axion"]+ (GenericEncoded '[] X3)++prop_WithConstantFieldsIn_encodes_as_expected :: Property+prop_WithConstantFieldsIn_encodes_as_expected = once . property $+ encode (X3 13)+ === "{\"xval\":13}"++prop_WithConstantFieldsIn_decodes_as_expected :: Property+prop_WithConstantFieldsIn_decodes_as_expected = once . property $+ decode @X3 "{\"xval\":9,\"quux\":\"axion\",\"bar\":\"baaz\"}" === Just (X3 9)++prop_WithConstantFieldsIn_extra_fields_required_when_decoding :: Property+prop_WithConstantFieldsIn_extra_fields_required_when_decoding = once . property $+ decode @X3 "{\"xval\":9}" === Nothing++data Y = Y {yval :: Int}+ deriving stock (Generic, Show, Eq)+ deriving (FromJSON, ToJSON) via+ SingleFieldObject "boop" (GenericEncoded '[] Y)++prop_single_field_objects_encode_as_expected :: Property+prop_single_field_objects_encode_as_expected = once . property $+ encode (Y 7)+ === "{\"boop\":{\"yval\":7}}"++prop_single_field_objects_decode_as_expected :: Property+prop_single_field_objects_decode_as_expected = once . property $+ tripping (Y 7) encode decode++data Z = Z {zval :: String}+ deriving stock (Generic, Show, Eq)+ deriving (FromJSON, ToJSON) via+ RemapTextField "zval" "bad" "good" (GenericEncoded '[] Z)++prop_remapped_text_fields_encode_as_expected :: Property+prop_remapped_text_fields_encode_as_expected = once . property $ do+ encode (Z "bad") === "{\"zval\":\"good\"}"+ encode (Z "cat") === "{\"zval\":\"cat\"}"++prop_remapped_text_fields_decode_as_expected :: Property+prop_remapped_text_fields_decode_as_expected = once . property $ do+ tripping (Z "bad") encode decode+ tripping (Z "cat") encode decode+ Just (Z "bad") === decode "{\"zval\":\"good\"}"+ Just (Z "cat") === decode "{\"zval\":\"cat\"}"++data Reserved = Reserved+ { type_ :: String+ , xyzmodule :: Int+ , control :: Char+ }+ deriving stock (Generic, Show, Eq)+ deriving (FromJSON, ToJSON) via+ Reserved &+ GenericEncoded+ '[FieldLabelModifier := [DropPrefix "xyz", DropSuffix "_"]]++prop_drop_prefix_suffix_fields_encode_as_expected :: Property+prop_drop_prefix_suffix_fields_encode_as_expected = once . property $ do+ encode (Reserved "Sen" 9 'x') ===+ "{\"control\":\"x\",\"module\":9,\"type\":\"Sen\"}"++prop_drop_prefix_suffix_fields_decode_as_expected :: Property+prop_drop_prefix_suffix_fields_decode_as_expected = once . property $ do+ tripping (Reserved "Sen" 9 'x') encode decode+ Just (Reserved "Sen" 9 'x') ===+ decode "{\"control\":\"x\",\"module\":9,\"type\":\"Sen\"}"