diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,94 @@ +# aeson-deriving + +[![Build Status](https://travis-ci.org/fieldstrength/aeson-deriving.svg?branch=master)](https://travis-ci.org/fieldstrength/aeson-deriving) +[![Hackage](https://img.shields.io/hackage/v/aeson-deriving.svg)](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... diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/aeson-deriving.cabal b/aeson-deriving.cabal new file mode 100644 --- /dev/null +++ b/aeson-deriving.cabal @@ -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 +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 diff --git a/src/Data/Aeson/Deriving.hs b/src/Data/Aeson/Deriving.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Deriving.hs @@ -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 diff --git a/src/Data/Aeson/Deriving/Generic.hs b/src/Data/Aeson/Deriving/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Deriving/Generic.hs @@ -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 diff --git a/src/Data/Aeson/Deriving/Internal/Generic.hs b/src/Data/Aeson/Deriving/Internal/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Deriving/Internal/Generic.hs @@ -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) diff --git a/src/Data/Aeson/Deriving/Internal/RecordSum.hs b/src/Data/Aeson/Deriving/Internal/RecordSum.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Deriving/Internal/RecordSum.hs @@ -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 diff --git a/src/Data/Aeson/Deriving/Known.hs b/src/Data/Aeson/Deriving/Known.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Deriving/Known.hs @@ -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 diff --git a/src/Data/Aeson/Deriving/ModifyField.hs b/src/Data/Aeson/Deriving/ModifyField.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Deriving/ModifyField.hs @@ -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) diff --git a/src/Data/Aeson/Deriving/SingleFieldObject.hs b/src/Data/Aeson/Deriving/SingleFieldObject.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Deriving/SingleFieldObject.hs @@ -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) diff --git a/src/Data/Aeson/Deriving/Utils.hs b/src/Data/Aeson/Deriving/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Deriving/Utils.hs @@ -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 diff --git a/src/Data/Aeson/Deriving/WithConstantFields.hs b/src/Data/Aeson/Deriving/WithConstantFields.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Deriving/WithConstantFields.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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\"}"