├── .gitignore ├── Setup.hs ├── stack.yaml ├── src └── Data │ └── Aeson │ ├── Deriving │ ├── Text.hs │ ├── Text │ │ └── Unsafe.hs │ ├── Utils.hs │ ├── EmptyObject.hs │ ├── SingleFieldObject.hs │ ├── Generic.hs │ ├── ModifyField.hs │ ├── WithConstantFields.hs │ ├── Known.hs │ └── Internal │ │ ├── RecordSum.hs │ │ └── Generic.hs │ └── Deriving.hs ├── ChangeLog.md ├── stack.yaml.lock ├── LICENSE ├── package.yaml ├── aeson-deriving.cabal ├── README.md ├── .travis.yml └── test └── Main.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ 3 | dist/ 4 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | 2 | resolver: lts-16.12 3 | 4 | packages: 5 | - . 6 | -------------------------------------------------------------------------------- /src/Data/Aeson/Deriving/Text.hs: -------------------------------------------------------------------------------- 1 | module Data.Aeson.Deriving.Text 2 | ( TextWithPattern 3 | ) where 4 | 5 | import Data.Aeson.Deriving.Text.Unsafe (TextWithPattern) 6 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for aeson-deriving 2 | 3 | ### 0.1.2 4 | 5 | * Added `EmptyObject` newtype for single-constructor types to be encoded as an empty JSON object. 6 | 7 | ### 0.1.1 8 | 9 | * Added `TextWithPattern` newtype for Text validated against a regex pattern [PR 2](https://github.com/fieldstrength/aeson-deriving/pull/2) 10 | 11 | ## 0.1.0 12 | 13 | * First version. Released on an unsuspecting world. 14 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 532377 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/12.yaml 11 | sha256: f914cfa23fef85bdf895e300a8234d9d0edc2dbec67f4bc9c53f85867c50eab6 12 | original: lts-16.12 13 | -------------------------------------------------------------------------------- /src/Data/Aeson/Deriving.hs: -------------------------------------------------------------------------------- 1 | module Data.Aeson.Deriving (module AllExports) where 2 | 3 | import Data.Aeson.Deriving.Generic as AllExports 4 | import Data.Aeson.Deriving.Known as AllExports 5 | import Data.Aeson.Deriving.ModifyField as AllExports 6 | import Data.Aeson.Deriving.SingleFieldObject as AllExports 7 | import Data.Aeson.Deriving.Text as AllExports 8 | import Data.Aeson.Deriving.WithConstantFields as AllExports 9 | import Data.Aeson.Deriving.EmptyObject as AllExports 10 | -------------------------------------------------------------------------------- /src/Data/Aeson/Deriving/Text/Unsafe.hs: -------------------------------------------------------------------------------- 1 | module Data.Aeson.Deriving.Text.Unsafe where 2 | 3 | import Control.Monad (unless) 4 | import Data.Aeson 5 | import Data.Proxy 6 | import Data.Text (Text, unpack) 7 | import Text.Regex.TDFA ((=~)) 8 | import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) 9 | 10 | newtype TextWithPattern (regex :: Symbol) = TextWithPattern Text 11 | deriving newtype (ToJSON) 12 | 13 | instance KnownSymbol regex => FromJSON (TextWithPattern regex) where 14 | parseJSON = withText "Text" $ \s -> 15 | TextWithPattern s <$ unless (unpack s =~ (symbolVal $ Proxy @regex)) (fail errorMsg) 16 | where 17 | errorMsg = "must match regex " <> (symbolVal $ Proxy @regex) 18 | -------------------------------------------------------------------------------- /src/Data/Aeson/Deriving/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PolyKinds #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module Data.Aeson.Deriving.Utils 5 | ( mapObjects 6 | , mapField 7 | , All 8 | , textVal 9 | ) where 10 | 11 | import Data.Aeson 12 | import qualified Data.HashMap.Strict as HashMap 13 | import Data.Kind (Constraint) 14 | import Data.Proxy 15 | import Data.Text 16 | import GHC.TypeLits 17 | 18 | mapObjects :: (Object -> Object) -> Value -> Value 19 | mapObjects f (Object o) = Object (f o) 20 | mapObjects _ val = val 21 | 22 | mapField :: Text -> (Value -> Value) -> Object -> Object 23 | mapField str f = HashMap.mapWithKey $ \s x -> 24 | if s == str then f x else x 25 | 26 | -- | Convenience constraint family. All @types@ in the list satisfy the @predicate@. 27 | type family All (predicate :: k -> Constraint) (types :: [k]) :: Constraint where 28 | All predicate '[] = () 29 | All predicate (t ': ts) = (predicate t, All predicate ts) 30 | 31 | 32 | textVal :: KnownSymbol s => Proxy s -> Text 33 | textVal = pack . symbolVal 34 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Cliff Harvey (c) 2019 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /src/Data/Aeson/Deriving/EmptyObject.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | -- | Allow unit-like types to be serialized as the empty object 4 | -- This can be combined with 'WithConstantFields'. 5 | module Data.Aeson.Deriving.EmptyObject where 6 | 7 | import Data.Aeson 8 | import Data.Kind (Type) 9 | import GHC.Generics 10 | 11 | -- | For data types with exactly one value, this data type changes the serialization to be the empty JSON object. 12 | -- It can be combined with 'WithConstantFields'. 13 | newtype EmptyObject a = EmptyObject a 14 | 15 | instance UnitLike (Rep a) => ToJSON (EmptyObject a) where 16 | toJSON _ = object [] 17 | 18 | instance (Generic a, UnitLike (Rep a)) => FromJSON (EmptyObject a) where 19 | parseJSON = withObject "object" $ \_hashmap -> 20 | pure . EmptyObject $ to gPoint 21 | 22 | 23 | -- | class for data types with a single constructor 24 | class UnitLike (f :: Type -> Type) where 25 | gPoint :: f a 26 | 27 | instance UnitLike U1 where 28 | gPoint = U1 29 | 30 | instance UnitLike a => UnitLike (M1 C meta a) where 31 | gPoint = M1 gPoint 32 | 33 | instance UnitLike a => UnitLike (M1 D meta a) where 34 | gPoint = M1 gPoint 35 | 36 | 37 | -------------------------------------------------------------------------------- /src/Data/Aeson/Deriving/SingleFieldObject.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Data.Aeson.Deriving.SingleFieldObject where 4 | 5 | import Data.Aeson 6 | import Data.Aeson.Deriving.Generic (LoopWarning) 7 | import Data.Proxy 8 | import Data.Text (pack) 9 | import GHC.Generics 10 | import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) 11 | 12 | -- | Puts the entire output of encoding the inner type within a single field 13 | newtype SingleFieldObject (fieldName :: Symbol) a = SingleFieldObject a 14 | deriving stock (Generic) 15 | 16 | instance (ToJSON a, LoopWarning (SingleFieldObject fieldName) a, KnownSymbol fieldName) => 17 | ToJSON (SingleFieldObject fieldName a) where 18 | toJSON (SingleFieldObject a) = object 19 | [ ( pack . symbolVal $ Proxy @fieldName 20 | , toJSON a 21 | ) 22 | ] 23 | 24 | instance (FromJSON a, LoopWarning (SingleFieldObject fieldName) a, KnownSymbol fieldName) => FromJSON (SingleFieldObject fieldName a) where 25 | parseJSON = withObject "Object" $ \hm -> 26 | SingleFieldObject <$> hm .: (pack . symbolVal $ Proxy @fieldName) 27 | -------------------------------------------------------------------------------- /src/Data/Aeson/Deriving/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PolyKinds #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | module Data.Aeson.Deriving.Generic 6 | ( -- * Typeclass for aeson 'Options' 7 | ToAesonOptions(..) 8 | -- * newtypes for Generic encodings 9 | -- ** Main data type for Generic encodings 10 | , GenericEncoded(..) 11 | -- ** Data type for encodings of composite "sum-of-records" types 12 | , RecordSumEncoded(..) 13 | -- * Phantom types for specifying Options 14 | -- ** Many-parameter type for explicitly providing all 'Options' fields. 15 | , GenericOptions 16 | -- ** Types for supplying specific Options fields 17 | -- *** Type representing field assignment 18 | , (:=) 19 | -- *** Typeclass for Options fields 20 | , ToAesonOptionsField 21 | -- *** Types representing Options fields 22 | , FieldLabelModifier 23 | , ConstructorTagModifier 24 | , AllNullaryToStringTag 25 | , OmitNothingFields 26 | , SumEncoding -- technically an aeson reexport. Shouldn't matter. 27 | , UnwrapUnaryRecords 28 | , TagSingleConstructors 29 | -- *** String Functions 30 | , StringFunction(..) 31 | , SnakeCase 32 | , Uppercase 33 | , Lowercase 34 | , FirstChar 35 | , DropLowercasePrefix 36 | , DropPrefix 37 | , DropSuffix 38 | , Id 39 | , snakeCase 40 | , dropLowercasePrefix 41 | -- *** Sum encoding options 42 | , ToSumEncoding 43 | , UntaggedValue 44 | , ObjectWithSingleField 45 | , TwoElemArray 46 | , TaggedObject 47 | -- * Safety class 48 | , LoopWarning 49 | , DisableLoopWarning(..) 50 | -- * Convenience newtype 51 | , type (&) (Ampersand) 52 | , unAmpersand 53 | ) where 54 | 55 | import Data.Aeson 56 | import Data.Aeson.Deriving.Internal.Generic 57 | import Data.Aeson.Deriving.Known 58 | -------------------------------------------------------------------------------- /src/Data/Aeson/Deriving/ModifyField.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | module Data.Aeson.Deriving.ModifyField where 6 | 7 | import Data.Aeson 8 | import Data.Aeson.Deriving.Generic 9 | import Data.Aeson.Deriving.Known 10 | import Data.Aeson.Deriving.Utils 11 | import Data.Proxy 12 | import GHC.Generics 13 | import GHC.TypeLits (KnownSymbol, Symbol) 14 | 15 | -- | Modify the contents of a particular field while decoding. 16 | newtype ModifyFieldIn (fieldName :: Symbol) fun a = ModifyFieldIn a 17 | deriving stock Generic 18 | deriving ToJSON via a 19 | 20 | instance 21 | ( FromJSON a 22 | , KnownSymbol fieldName 23 | , KnownJSONFunction fun 24 | , LoopWarning (ModifyFieldIn fieldName fun) a) 25 | => FromJSON (ModifyFieldIn fieldName fun a) where 26 | parseJSON 27 | = fmap ModifyFieldIn 28 | . parseJSON @a 29 | . mapObjects (mapField (textVal $ Proxy @fieldName) (functionVal $ Proxy @fun)) 30 | 31 | -- | Modify the contents of a particular field while encoding. 32 | newtype ModifyFieldOut (fieldName :: Symbol) fun a = ModifyFieldOut a 33 | deriving stock Generic 34 | deriving FromJSON via a 35 | 36 | instance 37 | ( ToJSON a 38 | , KnownSymbol fieldName 39 | , KnownJSONFunction fun 40 | , LoopWarning (ModifyFieldOut fieldName fun) a) 41 | => ToJSON (ModifyFieldOut fieldName fun a) where 42 | toJSON (ModifyFieldOut x) 43 | = mapObjects (mapField (textVal $ Proxy @fieldName) (functionVal $ Proxy @fun)) 44 | $ toJSON x 45 | 46 | newtype RemapTextField fieldName haskVal jsonVal a = RemapTextField 47 | (ModifyFieldOut fieldName (haskVal ==> jsonVal) 48 | (ModifyFieldIn fieldName (jsonVal ==> haskVal) a)) 49 | deriving newtype (FromJSON, ToJSON) 50 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: aeson-deriving 2 | version: 0.1.1.2 3 | github: "fieldstrength/aeson-deriving" 4 | license: MIT 5 | author: "Cliff Harvey" 6 | maintainer: "cs.hbar+hs@gmail.com" 7 | copyright: "2020" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | synopsis: data types for compositional, type-directed serialization 14 | 15 | category: Serialization 16 | 17 | description: Please see the README on GitHub at 18 | 19 | default-extensions: 20 | - ConstraintKinds 21 | - DataKinds 22 | - DeriveFunctor 23 | - DeriveGeneric 24 | - DerivingStrategies 25 | - FlexibleContexts 26 | - FlexibleInstances 27 | - GeneralizedNewtypeDeriving 28 | - KindSignatures 29 | - LambdaCase 30 | - MultiParamTypeClasses 31 | - NamedFieldPuns 32 | - OverloadedStrings 33 | - ScopedTypeVariables 34 | - TupleSections 35 | - TypeApplications 36 | - TypeOperators 37 | 38 | dependencies: 39 | - base >= 4.7 && < 5 40 | - aeson >= 1.2 && < 1.6 41 | - unordered-containers 42 | - text 43 | - regex-tdfa 44 | 45 | tests: 46 | spec: 47 | ghc-options: 48 | - -Wall 49 | - -Wredundant-constraints 50 | - -Wincomplete-record-updates 51 | - -Wincomplete-uni-patterns 52 | source-dirs: test 53 | main: 54 | Main.hs 55 | 56 | dependencies: 57 | - aeson-deriving 58 | - hedgehog 59 | 60 | library: 61 | ghc-options: 62 | - -Wall 63 | - -Wredundant-constraints 64 | - -Wincomplete-record-updates 65 | - -Wincomplete-uni-patterns 66 | source-dirs: src 67 | 68 | exposed-modules: 69 | - Data.Aeson.Deriving 70 | - Data.Aeson.Deriving.Internal.Generic 71 | - Data.Aeson.Deriving.Internal.RecordSum 72 | - Data.Aeson.Deriving.Generic 73 | - Data.Aeson.Deriving.Known 74 | - Data.Aeson.Deriving.ModifyField 75 | - Data.Aeson.Deriving.SingleFieldObject 76 | - Data.Aeson.Deriving.EmptyObject 77 | - Data.Aeson.Deriving.Utils 78 | - Data.Aeson.Deriving.WithConstantFields 79 | - Data.Aeson.Deriving.Text 80 | - Data.Aeson.Deriving.Text.Unsafe 81 | -------------------------------------------------------------------------------- /src/Data/Aeson/Deriving/WithConstantFields.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | module Data.Aeson.Deriving.WithConstantFields where 6 | 7 | import Control.Monad (unless) 8 | import Data.Aeson 9 | import Data.Aeson.Deriving.Generic 10 | import Data.Aeson.Deriving.Known 11 | import Data.Aeson.Deriving.Utils 12 | import qualified Data.HashMap.Strict as HashMap 13 | import Data.Kind (Type) 14 | import Data.Proxy 15 | import GHC.Generics 16 | 17 | -- | Add arbitrary constant fields to the encoded object and require them when decoding. 18 | newtype WithConstantFields (obj :: k) (a :: Type) = WithConstantFields a 19 | deriving stock (Generic) 20 | 21 | -- | Add arbitrary constant fields to the encoded object, but do not require them when 22 | -- decoding. 23 | newtype WithConstantFieldsOut (obj :: k) (a :: Type) = WithConstantFieldsOut a 24 | deriving stock (Generic) 25 | deriving ToJSON via (WithConstantFields obj a) 26 | deriving FromJSON via a 27 | 28 | -- | Require arbitrary constant fields when decoding the object, but do not add them when 29 | -- encoding. 30 | newtype WithConstantFieldsIn (obj :: k) (a :: Type) = WithConstantFieldsIn a 31 | deriving stock (Generic) 32 | deriving ToJSON via a 33 | deriving FromJSON via (WithConstantFields obj a) 34 | 35 | 36 | instance (ToJSON a, LoopWarning (WithConstantFields obj) a, KnownJSONObject obj) => 37 | ToJSON (WithConstantFields obj a) where 38 | toJSON (WithConstantFields x) = mapObjects (<> fields) $ toJSON x 39 | where 40 | fields = objectVal $ Proxy @obj 41 | 42 | instance (FromJSON a, LoopWarning (WithConstantFields obj) a, KnownJSONObject obj) => FromJSON (WithConstantFields obj a) where 43 | parseJSON valIn = WithConstantFields <$> 44 | parseJSON valIn <* 45 | HashMap.traverseWithKey assertFieldPresent (objectVal $ Proxy @obj) 46 | 47 | where 48 | assertFieldPresent key valExpected = 49 | flip (withObject "Object") valIn $ \obj -> do 50 | valActual <- obj .: key 51 | unless (valActual == valExpected) . fail $ 52 | "Expected constant value " <> showEscapedJson valExpected <> 53 | " but got: " <> showEscapedJson valActual 54 | 55 | showEscapedJson val = show (encode val) 56 | -------------------------------------------------------------------------------- /aeson-deriving.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.33.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 05a421de32621a1d52633e1311198dbc32abe2ea1f27c1e0f003d14a579b97e5 8 | 9 | name: aeson-deriving 10 | version: 0.1.1.2 11 | synopsis: data types for compositional, type-directed serialization 12 | description: Please see the README on GitHub at 13 | category: Serialization 14 | homepage: https://github.com/fieldstrength/aeson-deriving#readme 15 | bug-reports: https://github.com/fieldstrength/aeson-deriving/issues 16 | author: Cliff Harvey 17 | maintainer: cs.hbar+hs@gmail.com 18 | copyright: 2020 19 | license: MIT 20 | license-file: LICENSE 21 | build-type: Simple 22 | extra-source-files: 23 | README.md 24 | ChangeLog.md 25 | 26 | source-repository head 27 | type: git 28 | location: https://github.com/fieldstrength/aeson-deriving 29 | 30 | library 31 | exposed-modules: 32 | Data.Aeson.Deriving 33 | Data.Aeson.Deriving.Internal.Generic 34 | Data.Aeson.Deriving.Internal.RecordSum 35 | Data.Aeson.Deriving.Generic 36 | Data.Aeson.Deriving.Known 37 | Data.Aeson.Deriving.ModifyField 38 | Data.Aeson.Deriving.SingleFieldObject 39 | Data.Aeson.Deriving.EmptyObject 40 | Data.Aeson.Deriving.Utils 41 | Data.Aeson.Deriving.WithConstantFields 42 | Data.Aeson.Deriving.Text 43 | Data.Aeson.Deriving.Text.Unsafe 44 | other-modules: 45 | Paths_aeson_deriving 46 | hs-source-dirs: 47 | src 48 | default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveGeneric DerivingStrategies FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings ScopedTypeVariables TupleSections TypeApplications TypeOperators 49 | ghc-options: -Wall -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns 50 | build-depends: 51 | aeson >=1.2 && <1.6 52 | , base >=4.7 && <5 53 | , regex-tdfa 54 | , text 55 | , unordered-containers 56 | default-language: Haskell2010 57 | 58 | test-suite spec 59 | type: exitcode-stdio-1.0 60 | main-is: Main.hs 61 | other-modules: 62 | Paths_aeson_deriving 63 | hs-source-dirs: 64 | test 65 | default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveGeneric DerivingStrategies FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings ScopedTypeVariables TupleSections TypeApplications TypeOperators 66 | ghc-options: -Wall -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns 67 | build-depends: 68 | aeson >=1.2 && <1.6 69 | , aeson-deriving 70 | , base >=4.7 && <5 71 | , hedgehog 72 | , regex-tdfa 73 | , text 74 | , unordered-containers 75 | default-language: Haskell2010 76 | -------------------------------------------------------------------------------- /src/Data/Aeson/Deriving/Known.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PolyKinds #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | module Data.Aeson.Deriving.Known where 5 | 6 | import Data.Aeson 7 | import qualified Data.HashMap.Strict as HashMap 8 | import Data.Kind (Type) 9 | import Data.Proxy 10 | import Data.Text (pack) 11 | import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) 12 | 13 | 14 | infix 3 := 15 | infix 6 ==> 16 | 17 | 18 | -- | Represents the null JSON 'Value'. 19 | data Null 20 | 21 | -- | Phantom data type to make explicit which fields we pass for Aeson options. Polykinded 22 | -- in the second argument so it can take i.e. Booleans or Symbols where needed. 23 | -- 24 | -- Also used for specifying constant values added to, or required from, an encoding. 25 | -- See "Data.Aeson.Deriving.WithConstantFields". 26 | data field := (value :: k) 27 | 28 | -- | Represents a function that maps the first value to the second, 29 | -- and otherwise does nothing but return the input. 30 | data a ==> b 31 | 32 | -- | Represents the function that turns nulls into the given default value. 33 | data WithDefault (val :: k) 34 | 35 | -- | Constant JSON values 36 | class KnownJSON (a :: k) where jsonVal :: Proxy a -> Value 37 | 38 | instance KnownSymbol str => KnownJSON (str :: Symbol) where jsonVal = String . pack . symbolVal 39 | instance KnownBool b => KnownJSON (b :: Bool) where jsonVal = Bool . boolVal 40 | instance KnownJSON Null where jsonVal Proxy = Null 41 | instance KnownJSONList (xs :: [k]) => KnownJSON xs where jsonVal Proxy = toJSON $ listVal (Proxy @xs) 42 | 43 | -- | Constant boolean values 44 | class KnownBool (b :: Bool) where boolVal :: Proxy b -> Bool 45 | 46 | instance KnownBool 'True where boolVal Proxy = True 47 | instance KnownBool 'False where boolVal Proxy = False 48 | 49 | -- | Constant JSON lists 50 | class KnownJSONList (xs :: [k]) where listVal :: Proxy xs -> [Value] 51 | 52 | instance KnownJSONList '[] where listVal Proxy = [] 53 | instance (KnownJSON x, KnownJSONList xs) => KnownJSONList (x ': xs) where 54 | listVal Proxy = jsonVal (Proxy @x) : listVal (Proxy @xs) 55 | 56 | 57 | -- | Constant JSON objects 58 | class KnownJSONObject (a :: k) where objectVal :: Proxy a -> Object 59 | 60 | instance KnownJSONObject '[] where objectVal Proxy = mempty 61 | instance (KnownJSONObject fields, KnownSymbol key, KnownJSON val) 62 | => KnownJSONObject ((key := val) ': fields) where 63 | objectVal Proxy = 64 | HashMap.insert 65 | (pack . symbolVal $ Proxy @key) 66 | (jsonVal $ Proxy @val) 67 | (objectVal $ Proxy @fields) 68 | 69 | 70 | -- | JSON ('Value') functions 71 | class KnownJSONFunction (a :: Type) where functionVal :: Proxy a -> Value -> Value 72 | 73 | -- instance All KnownJSON [a, b] => KnownJSONFunction (a ==> b) where 74 | instance (KnownJSON a, KnownJSON b) => KnownJSONFunction (a ==> b) where 75 | functionVal Proxy x 76 | | x == jsonVal (Proxy @a) = jsonVal (Proxy @b) 77 | | otherwise = x 78 | 79 | instance KnownJSON a => KnownJSONFunction (WithDefault a) where 80 | functionVal Proxy = \case 81 | Null -> jsonVal $ Proxy @a 82 | x -> x 83 | -------------------------------------------------------------------------------- /src/Data/Aeson/Deriving/Internal/RecordSum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Data.Aeson.Deriving.Internal.RecordSum where 4 | 5 | import Data.Aeson 6 | import Data.Aeson.Types (Parser) 7 | import Data.Bifunctor (first) 8 | import Data.HashMap.Strict (HashMap) 9 | import qualified Data.HashMap.Strict as HashMap 10 | import Data.Kind (Type) 11 | import Data.Proxy 12 | import GHC.Generics 13 | 14 | 15 | newtype ParserMap a = ParserMap (HashMap String (Value -> Parser a)) 16 | deriving stock Functor 17 | deriving newtype (Semigroup, Monoid) 18 | 19 | unsafeMapKeys :: (String -> String) -> ParserMap a -> ParserMap a 20 | unsafeMapKeys f (ParserMap hm) 21 | = ParserMap 22 | . HashMap.fromList 23 | . fmap (first f) 24 | $ HashMap.toList hm 25 | 26 | -- | Provides a map from the (Haskell) constructor names of the inner contained types, 27 | -- To parsers for the (Rep of the) outer data type that carries them. 28 | class GTagParserMap (repA :: Type -> Type) where 29 | gParserMap :: Proxy repA -> ParserMap (repA x) 30 | 31 | -- | We can create a ParserMap from any reference to a data type that has a 32 | -- FromJSON instance (and at least one available constructor). 33 | instance (GConstructorNames (Rep a), FromJSON a) => GTagParserMap (Rec0 a) where 34 | gParserMap _ = ParserMap . HashMap.fromList $ do 35 | constructorName <- gConstructorNames $ Proxy @(Rep a) 36 | [(constructorName, fmap K1 . parseJSON)] 37 | 38 | -- | ParserMaps are trivially extended to the representation of fields under a constructor 39 | instance GTagParserMap repA => GTagParserMap (S1 meta repA) where 40 | gParserMap _ = M1 <$> gParserMap (Proxy @repA) 41 | 42 | -- | ParserMaps are extended to the canonical representation of a constructor. 43 | -- Because there is no instance for :*:, this constraint is only satisfied for types 44 | -- with a single constructor (with an S1 Directly under the C1 in the canonical rep). 45 | instance GTagParserMap repA => GTagParserMap (C1 meta repA) where 46 | gParserMap _ = M1 <$> gParserMap (Proxy @repA) 47 | 48 | -- | ParserMaps corresponding to different cases of a sum type are combined by merging. 49 | instance (GTagParserMap repA, GTagParserMap repB) => GTagParserMap (repA :+: repB) where 50 | gParserMap _ = 51 | (L1 <$> gParserMap (Proxy @repA)) 52 | <> (R1 <$> gParserMap (Proxy @repB)) 53 | 54 | -- | The ParserMap for the whole data type is now the one we get from under this D1 constructor. 55 | instance GTagParserMap repA => GTagParserMap (D1 meta repA) where 56 | gParserMap _ = M1 <$> gParserMap (Proxy @repA) 57 | 58 | 59 | -- | Provides constructor names 60 | class GConstructorNames (repA :: Type -> Type) where 61 | gConstructorNames :: Proxy repA -> [String] 62 | 63 | instance Constructor constructorMeta => GConstructorNames (C1 constructorMeta r) where 64 | gConstructorNames _ = [conName @constructorMeta undefined] 65 | 66 | instance (GConstructorNames x, GConstructorNames y) => GConstructorNames (x :+: y) where 67 | gConstructorNames _ = 68 | gConstructorNames (Proxy @x) 69 | <> gConstructorNames (Proxy @y) 70 | 71 | instance GConstructorNames r => GConstructorNames (D1 datatypeMeta r) where 72 | gConstructorNames _ = gConstructorNames $ Proxy @r 73 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # aeson-deriving 2 | 3 | [![Build Status](https://travis-ci.org/fieldstrength/aeson-deriving.svg?branch=master)](https://travis-ci.org/fieldstrength/aeson-deriving) 4 | [![Hackage](https://img.shields.io/hackage/v/aeson-deriving.svg)](http://hackage.haskell.org/package/aeson-deriving) 5 | 6 | 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. 7 | 8 | ## Uses and examples 9 | 10 | ### Basic encoding options & common patterns 11 | 12 | Aeson's generics support governs the basic mapping between Haskell definitions and the JSON format. 13 | This functionality, along with its tunable parameters, can be specified with the `GenericEncoded` newtype. 14 | 15 | ```haskell 16 | type MyEncoding = GenericEncoded 17 | '[ ConstructorTagModifier := SnakeCase -- extensible function support 18 | , FieldLabelModifier := 19 | [ SnakeCase, DropSuffix "_" ] -- functions can be composed 20 | , SumEncoding := TaggedObject "type" "contents" 21 | ] 22 | 23 | 24 | data User = User 25 | { firstName :: Text 26 | , id_ :: UserId 27 | , companyId :: CompanyId 28 | } 29 | deriving stock (Generic, Show) 30 | deriving (FromJSON, ToJSON) 31 | via MyEncoding User 32 | 33 | data Document = Document 34 | { name :: Text 35 | , id_ :: Int64 36 | , companyId :: CompanyId 37 | , parts :: [SubDocument] 38 | } 39 | deriving stock (Generic, Show) 40 | deriving (FromJSON, ToJSON) 41 | via MyEncoding Document 42 | 43 | -- >>> encode (User "jake" 1 29) 44 | -- { "type": "user", "first_name": "jake", "id": 1, "company_id": 29} 45 | ``` 46 | 47 | ### Modifier newtypes 48 | 49 | #### Constrant Fields 50 | 51 | ```haskell 52 | data Transaction = Transaction 53 | { transactionId :: UUID } 54 | deriving stock (Generic, Show) 55 | deriving (FromJSON, ToJSON) via 56 | WithConstantFieldsOut 57 | '[ "version" := "1.0" 58 | , "system_info" := "👍" 59 | ] 60 | (MyEncoding Transaction) 61 | ``` 62 | 63 | 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`. 64 | 65 | #### Constant Objects 66 | 67 | Sometimes you may need an entire object of constant fields, with no information passing to the haskell representation. This is modeled as a single-value type and can also be used with the `WithConstantFields` newtype, as long as the base type is wrapped in the `EmptyObject` newtype (because otherwise unit types do not serialize to the empty object by default). 68 | 69 | ```haskell 70 | data Requirements = Requirements 71 | deriving (Show, Eq, Generic) 72 | deriving (FromJSON, ToJSON) via 73 | WithConstantFields 74 | '[ "api_version" := "2.0" 75 | , "check_performed" := 'True 76 | ] 77 | (EmptyObject Requirements) 78 | ``` 79 | 80 | #### Apply arbitrary functions before encoding/decoding 81 | 82 | ##### Example: Special treatment for magic values 83 | 84 | ```haskell 85 | data Feedback = Feedback 86 | { comment :: Text } 87 | deriving stock (Generic, Show) 88 | deriving (FromJSON, ToJSON) via 89 | ModifyFieldIn "comment" 90 | ("booo!" ==> "boo-urns!") 91 | (MyEncoding Feedback) 92 | 93 | 94 | -- x ==> y maps the value x to y and leaves others unchanged 95 | -- Implement your own instances of `KnownJSONFunction` for other behavior 96 | 97 | ``` 98 | 99 | ### Preventing infinite loops 100 | 101 | 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. 102 | 103 | This package employs a custom compiler error to prevent this very easy mistake. 104 | 105 | ### Improved error messages for sums of records 106 | 107 | See `RecordSumEncoded` documentation. 108 | 109 | To be expanded... 110 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This is the complex Travis configuration, which is intended for use 2 | # on open source libraries which need compatibility across multiple GHC 3 | # versions, must work with cabal-install, and should be 4 | # cross-platform. For more information and other options, see: 5 | # 6 | # https://docs.haskellstack.org/en/stable/travis_ci/ 7 | # 8 | # Copy these contents into the root directory of your Github project in a file 9 | # named .travis.yml 10 | 11 | # Run jobs on Linux unless "os" is specified explicitly. 12 | os: linux 13 | 14 | # Do not choose a language; we provide our own build tools. 15 | language: generic 16 | 17 | # Caching so the next build will be fast too. 18 | cache: 19 | directories: 20 | - $HOME/.ghc 21 | - $HOME/.cabal 22 | - $HOME/.stack 23 | - $TRAVIS_BUILD_DIR/.stack-work 24 | 25 | # The different configurations we want to test. We have BUILD=cabal which uses 26 | # cabal-install, and BUILD=stack which uses Stack. More documentation on each 27 | # of those below. 28 | # 29 | # We set the compiler values here to tell Travis to use a different 30 | # cache file per set of arguments. 31 | # 32 | # If you need to have different apt packages for each combination in the 33 | # job matrix, you can use a line such as: 34 | # addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} 35 | jobs: 36 | include: 37 | - env: BUILD=cabal GHCVER=8.6.5 CABALVER=2.4 HAPPYVER=1.19.5 ALEXVER=3.1.7 38 | compiler: ": #GHC 8.6.5" 39 | addons: {apt: {packages: [cabal-install-2.4,ghc-8.6.5,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 40 | 41 | # Build with the newest GHC and cabal-install. This is an accepted failure, 42 | # see below. 43 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 44 | compiler: ": #GHC HEAD" 45 | addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 46 | 47 | # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS 48 | # variable, such as using --stack-yaml to point to a different file. 49 | - env: BUILD=stack ARGS="--resolver lts-14" 50 | compiler: ": #stack 8.6.5" 51 | addons: {apt: {packages: [libgmp-dev]}} 52 | 53 | - env: BUILD=stack ARGS="--resolver lts-15" 54 | compiler: ": #stack 8.8.3" 55 | addons: {apt: {packages: [libgmp-dev]}} 56 | 57 | # Nightly builds are allowed to fail 58 | - env: BUILD=stack ARGS="--resolver nightly" 59 | compiler: ": #stack nightly" 60 | addons: {apt: {packages: [libgmp-dev]}} 61 | 62 | # Build on macOS in addition to Linux 63 | - env: BUILD=stack ARGS="" 64 | compiler: ": #stack default osx" 65 | os: osx 66 | 67 | 68 | # OSX Bilds 69 | - env: BUILD=stack ARGS="--resolver lts-14" 70 | compiler: ": #stack 8.6.5 osx" 71 | os: osx 72 | 73 | - env: BUILD=stack ARGS="--resolver lts-15" 74 | compiler: ": #stack 8.8.3 osx" 75 | os: osx 76 | 77 | - env: BUILD=stack ARGS="--resolver nightly" 78 | compiler: ": #stack nightly osx" 79 | os: osx 80 | 81 | allow_failures: 82 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 83 | - env: BUILD=stack ARGS="--resolver nightly" 84 | 85 | before_install: 86 | # Using compiler above sets CC to an invalid value, so unset it 87 | - unset CC 88 | 89 | # We want to always allow newer versions of packages when building on GHC HEAD 90 | - CABALARGS="" 91 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 92 | 93 | # Download and unpack the stack executable 94 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH 95 | - mkdir -p ~/.local/bin 96 | - | 97 | if [ `uname` = "Darwin" ] 98 | then 99 | travis_retry curl --insecure -L https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 100 | else 101 | travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 102 | fi 103 | 104 | # Use the more reliable S3 mirror of Hackage 105 | mkdir -p $HOME/.cabal 106 | echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config 107 | echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config 108 | 109 | 110 | install: 111 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 112 | - if [ -f configure.ac ]; then autoreconf -i; fi 113 | - | 114 | set -ex 115 | case "$BUILD" in 116 | stack) 117 | # Add in extra-deps for older snapshots, as necessary 118 | # 119 | # This is disabled by default, as relying on the solver like this can 120 | # make builds unreliable. Instead, if you have this situation, it's 121 | # recommended that you maintain multiple stack-lts-X.yaml files. 122 | 123 | #stack --no-terminal --install-ghc $ARGS test --bench --dry-run || ( \ 124 | # stack --no-terminal $ARGS build cabal-install && \ 125 | # stack --no-terminal $ARGS solver --update-config) 126 | 127 | # Build the dependencies 128 | stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies 129 | ;; 130 | cabal) 131 | cabal --version 132 | travis_retry cabal update 133 | 134 | # Get the list of packages from the stack.yaml file. Note that 135 | # this will also implicitly run hpack as necessary to generate 136 | # the .cabal files needed by cabal-install. 137 | PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 138 | 139 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 140 | ;; 141 | esac 142 | set +ex 143 | 144 | script: 145 | - | 146 | set -ex 147 | case "$BUILD" in 148 | stack) 149 | stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps 150 | ;; 151 | cabal) 152 | cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 153 | 154 | ORIGDIR=$(pwd) 155 | for dir in $PACKAGES 156 | do 157 | cd $dir 158 | cabal check || [ "$CABALVER" == "1.16" ] 159 | cabal sdist 160 | PKGVER=$(cabal info . | awk '{print $2;exit}') 161 | SRC_TGZ=$PKGVER.tar.gz 162 | cd dist 163 | tar zxfv "$SRC_TGZ" 164 | cd "$PKGVER" 165 | cabal configure --enable-tests --ghc-options -O0 166 | cabal build 167 | if [ "$CABALVER" = "1.16" ] || [ "$CABALVER" = "1.18" ]; then 168 | cabal test 169 | else 170 | cabal test --show-details=streaming --log=/dev/stdout 171 | fi 172 | cd $ORIGDIR 173 | done 174 | ;; 175 | esac 176 | set +ex 177 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# Language DerivingVia #-} 2 | {-# Language DataKinds #-} 3 | {-# Language TemplateHaskell #-} 4 | {-# Language DeriveAnyClass #-} 5 | {-# Language DuplicateRecordFields #-} 6 | 7 | module Main where 8 | 9 | import Data.Aeson 10 | import Data.Aeson.Deriving 11 | import Data.Foldable (for_) 12 | import Data.Aeson.Deriving.Text.Unsafe 13 | import Data.Text 14 | import GHC.Generics 15 | import Hedgehog 16 | import Hedgehog.Main (defaultMain) 17 | 18 | main :: IO () 19 | main = defaultMain [checkParallel $$(discover)] 20 | 21 | type IdiomaticEncoded = 22 | GenericEncoded '[FieldLabelModifier := '[SnakeCase, DropLowercasePrefix]] 23 | 24 | data Dog = Dog 25 | { dogAgeInDogYears :: Int 26 | , dogName :: String 27 | } 28 | deriving stock (Generic, Show, Eq) 29 | deriving (ToJSON, FromJSON) via IdiomaticEncoded Dog 30 | 31 | once :: Property -> Property 32 | once = withTests 1 33 | 34 | prop_fido_encodes_as_expected :: Property 35 | prop_fido_encodes_as_expected = once . property $ 36 | encode (Dog 9 "fido") === "{\"name\":\"fido\",\"age_in_dog_years\":9}" 37 | 38 | prop_fido_decodes_as_expected :: Property 39 | prop_fido_decodes_as_expected = once . property $ 40 | tripping (Dog 9 "fido") encode eitherDecode 41 | 42 | 43 | type UppercaseTypeTagEncoded = 44 | GenericEncoded 45 | '[ FieldLabelModifier := '[SnakeCase, DropLowercasePrefix] 46 | , SumEncoding := TaggedObject "type" "contents" 47 | , TagSingleConstructors := 'True 48 | , ConstructorTagModifier := '[Uppercase, SnakeCase] 49 | ] 50 | 51 | data PostArticle = PostArticle 52 | { articleName :: String 53 | , articleText :: String 54 | } 55 | deriving stock (Generic, Show, Eq) 56 | deriving (ToJSON, FromJSON) via UppercaseTypeTagEncoded PostArticle 57 | 58 | data DeleteArticle = DeleteArticle 59 | { articleId :: Int 60 | } 61 | deriving stock (Generic, Show, Eq) 62 | deriving (ToJSON, FromJSON) via UppercaseTypeTagEncoded DeleteArticle 63 | 64 | data ArticleCommand 65 | = MkPostArticle PostArticle 66 | | MkDeleteArticle DeleteArticle 67 | deriving stock (Generic, Show, Eq) 68 | deriving (ToJSON, FromJSON) via RecordSumEncoded "type" '[Uppercase, SnakeCase] ArticleCommand 69 | 70 | prop_record_sum_encodes_as_expected :: Property 71 | prop_record_sum_encodes_as_expected = once . property $ 72 | encode (MkDeleteArticle $ DeleteArticle 9) 73 | === "{\"id\":9,\"type\":\"DELETE_ARTICLE\"}" 74 | 75 | prop_record_sum_decodes_as_expected :: Property 76 | prop_record_sum_decodes_as_expected = once . property $ 77 | tripping (MkDeleteArticle $ DeleteArticle 9) encode decode 78 | 79 | 80 | data MyVal 81 | instance KnownJSON MyVal where jsonVal _ = Number 1 82 | 83 | data X = X {xval :: Int} 84 | deriving stock (Generic, Show, Eq) 85 | deriving (FromJSON, ToJSON) via 86 | X 87 | & GenericEncoded '[] 88 | & WithConstantFields 89 | '["bar" := "baaz", "quux" := MyVal, "arr" := ["Hilbert","Dirac"]] 90 | 91 | prop_WithConstantFields_extra_fields_encode_as_expected :: Property 92 | prop_WithConstantFields_extra_fields_encode_as_expected = once . property $ 93 | encode (X 9) 94 | === "{\"xval\":9,\"arr\":[\"Hilbert\",\"Dirac\"],\"quux\":1,\"bar\":\"baaz\"}" 95 | 96 | prop_WithConstantFields_extra_fields_decode_as_expected :: Property 97 | prop_WithConstantFields_extra_fields_decode_as_expected = once . property $ 98 | tripping (X 9) encode decode 99 | 100 | prop_WithConstantFields_extra_fields_required_when_decoding :: Property 101 | prop_WithConstantFields_extra_fields_required_when_decoding = once . property $ 102 | decode @X "{\"xval\":9}" === Nothing 103 | 104 | data X2 = X2 {xval :: Int} 105 | deriving stock (Generic, Show, Eq) 106 | deriving (FromJSON, ToJSON) via 107 | WithConstantFieldsOut 108 | '["bar" := "baaz", "quux" := "axion"] 109 | (GenericEncoded '[] X2) 110 | 111 | prop_WithConstantFieldsOut_encodes_as_expected :: Property 112 | prop_WithConstantFieldsOut_encodes_as_expected = once . property $ 113 | encode (X2 9) 114 | === "{\"xval\":9,\"quux\":\"axion\",\"bar\":\"baaz\"}" 115 | 116 | prop_WithConstantFieldsOut_extra_fields_not_required_when_decoding :: Property 117 | prop_WithConstantFieldsOut_extra_fields_not_required_when_decoding = once . property $ 118 | decode @X2 "{\"xval\":9}" === Just (X2 9) 119 | 120 | data X3 = X3 {xval :: Int} 121 | deriving stock (Generic, Show, Eq) 122 | deriving (FromJSON, ToJSON) via 123 | WithConstantFieldsIn 124 | '["bar" := "baaz", "quux" := "axion"] 125 | (GenericEncoded '[] X3) 126 | 127 | prop_WithConstantFieldsIn_encodes_as_expected :: Property 128 | prop_WithConstantFieldsIn_encodes_as_expected = once . property $ 129 | encode (X3 13) 130 | === "{\"xval\":13}" 131 | 132 | prop_WithConstantFieldsIn_decodes_as_expected :: Property 133 | prop_WithConstantFieldsIn_decodes_as_expected = once . property $ 134 | decode @X3 "{\"xval\":9,\"quux\":\"axion\",\"bar\":\"baaz\"}" === Just (X3 9) 135 | 136 | prop_WithConstantFieldsIn_extra_fields_required_when_decoding :: Property 137 | prop_WithConstantFieldsIn_extra_fields_required_when_decoding = once . property $ 138 | decode @X3 "{\"xval\":9}" === Nothing 139 | 140 | data Y = Y {yval :: Int} 141 | deriving stock (Generic, Show, Eq) 142 | deriving (FromJSON, ToJSON) via 143 | SingleFieldObject "boop" (GenericEncoded '[] Y) 144 | 145 | prop_single_field_objects_encode_as_expected :: Property 146 | prop_single_field_objects_encode_as_expected = once . property $ 147 | encode (Y 7) 148 | === "{\"boop\":{\"yval\":7}}" 149 | 150 | prop_single_field_objects_decode_as_expected :: Property 151 | prop_single_field_objects_decode_as_expected = once . property $ 152 | tripping (Y 7) encode decode 153 | 154 | data Z = Z {zval :: String} 155 | deriving stock (Generic, Show, Eq) 156 | deriving (FromJSON, ToJSON) via 157 | RemapTextField "zval" "bad" "good" (GenericEncoded '[] Z) 158 | 159 | prop_remapped_text_fields_encode_as_expected :: Property 160 | prop_remapped_text_fields_encode_as_expected = once . property $ do 161 | encode (Z "bad") === "{\"zval\":\"good\"}" 162 | encode (Z "cat") === "{\"zval\":\"cat\"}" 163 | 164 | prop_remapped_text_fields_decode_as_expected :: Property 165 | prop_remapped_text_fields_decode_as_expected = once . property $ do 166 | tripping (Z "bad") encode decode 167 | tripping (Z "cat") encode decode 168 | Just (Z "bad") === decode "{\"zval\":\"good\"}" 169 | Just (Z "cat") === decode "{\"zval\":\"cat\"}" 170 | 171 | data Reserved = Reserved 172 | { type_ :: String 173 | , xyzmodule :: Int 174 | , control :: Char 175 | } 176 | deriving stock (Generic, Show, Eq) 177 | deriving (FromJSON, ToJSON) via 178 | Reserved & 179 | GenericEncoded 180 | '[FieldLabelModifier := [DropPrefix "xyz", DropSuffix "_"]] 181 | 182 | prop_drop_prefix_suffix_fields_encode_as_expected :: Property 183 | prop_drop_prefix_suffix_fields_encode_as_expected = once . property $ do 184 | encode (Reserved "Sen" 9 'x') === 185 | "{\"control\":\"x\",\"module\":9,\"type\":\"Sen\"}" 186 | 187 | prop_drop_prefix_suffix_fields_decode_as_expected :: Property 188 | prop_drop_prefix_suffix_fields_decode_as_expected = once . property $ do 189 | tripping (Reserved "Sen" 9 'x') encode decode 190 | Just (Reserved "Sen" 9 'x') === 191 | decode "{\"control\":\"x\",\"module\":9,\"type\":\"Sen\"}" 192 | 193 | newtype DashSeparatedWords = DashSeparatedWords Text 194 | deriving stock (Generic, Show, Eq) 195 | deriving (FromJSON, ToJSON) via TextWithPattern "^([A-Za-z]+-)*[A-Za-z]+$" 196 | 197 | prop_accepts_matches :: Property 198 | prop_accepts_matches = once . property $ do 199 | tripping (DashSeparatedWords "foo-bar-baz") encode decode 200 | Just (DashSeparatedWords "foo-bar-baz") === decode "\"foo-bar-baz\"" 201 | 202 | prop_rejects_non_matches :: Property 203 | prop_rejects_non_matches = once . property $ do 204 | Left "Error in $: must match regex ^([A-Za-z]+-)*[A-Za-z]+$" === eitherDecode @DashSeparatedWords "\"foo.42\"" 205 | 206 | 207 | data Heavy = BlackHole | NeutronStar 208 | deriving stock (Generic, Show, Eq, Ord, Bounded, Enum) 209 | deriving (FromJSON, ToJSON) via GenericEncoded '[ConstructorTagModifier := FirstChar Lowercase] Heavy 210 | 211 | prop_first_char_modifier_encodes_as_expected :: Property 212 | prop_first_char_modifier_encodes_as_expected = once . property $ do 213 | encode BlackHole === "\"blackHole\"" 214 | encode NeutronStar === "\"neutronStar\"" 215 | 216 | prop_first_char_modifier_decodes_as_expected :: Property 217 | prop_first_char_modifier_decodes_as_expected = once . property $ do 218 | for_ [BlackHole ..] $ \x -> 219 | tripping x encode decode 220 | 221 | 222 | data Unity = Unity 223 | deriving (Show, Eq, Generic) 224 | deriving (FromJSON, ToJSON) via EmptyObject Unity 225 | 226 | prop_empty_object_encodes_as_expected :: Property 227 | prop_empty_object_encodes_as_expected = once . property $ do 228 | encode Unity === "{}" 229 | 230 | prop_empty_object_decodes_as_expected :: Property 231 | prop_empty_object_decodes_as_expected = once . property $ tripping Unity encode decode 232 | 233 | -- An example of how to require a particular constant object 234 | data Requirements = Requirements 235 | deriving (Show, Eq, Generic) 236 | deriving (FromJSON, ToJSON) via 237 | WithConstantFields 238 | '[ "api_version" := "2.0" 239 | , "check_performed" := 'True 240 | ] 241 | (EmptyObject Requirements) 242 | 243 | prop_constant_object_encodes_as_expected :: Property 244 | prop_constant_object_encodes_as_expected = once . property $ 245 | encode Requirements === "{\"api_version\":\"2.0\",\"check_performed\":true}" 246 | 247 | prop_constant_object_decodes_as_expected :: Property 248 | prop_constant_object_decodes_as_expected = once . property $ tripping Requirements encode decode 249 | 250 | prop_reject_constant_object_with_incorrect_details :: Property 251 | prop_reject_constant_object_with_incorrect_details = once . property $ 252 | eitherDecode @Requirements "{\"api_version\":\"2.0\",\"check_performed\":false}" 253 | === Left "Error in $: Expected constant value \"true\" but got: \"false\"" 254 | -------------------------------------------------------------------------------- /src/Data/Aeson/Deriving/Internal/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PolyKinds #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | module Data.Aeson.Deriving.Internal.Generic where 6 | 7 | import Data.Aeson 8 | import Data.Aeson.Deriving.EmptyObject (EmptyObject(..)) 9 | import Data.Aeson.Deriving.Internal.RecordSum 10 | import Data.Aeson.Deriving.Known 11 | import Data.Aeson.Deriving.Utils 12 | import Data.Aeson.Types (modifyFailure) 13 | import Data.Char (isUpper, toLower, toUpper) 14 | import Data.Function ((&)) 15 | import qualified Data.HashMap.Strict as HashMap 16 | import Data.Kind (Constraint, Type) 17 | import Data.List (intercalate, stripPrefix) 18 | import Data.Maybe (fromMaybe) 19 | import Data.Proxy (Proxy (..)) 20 | import Data.Text (pack) 21 | import GHC.Generics 22 | import GHC.TypeLits 23 | 24 | ------------------------------------------------------------------------------------------ 25 | -- Main class 26 | ------------------------------------------------------------------------------------------ 27 | 28 | -- | A class for defining 'Options' for Aeson's Generic deriving support. 29 | -- It is generally instantiated by overriding specific fields using the instance 30 | -- for (type-level) list values. It can also be instantiated in a more exhaustive way 31 | -- using the 'GenericOptions' type. In both cases fields are specified in a record-like 32 | -- form using the '(:=)' data type for explicitness. 33 | -- 34 | -- See the ReadMe or tests for examples. 35 | -- 36 | -- Users may also provide instances for their own phantom data types if desired. 37 | class ToAesonOptions a where 38 | toAesonOptions :: Proxy a -> Options 39 | 40 | instance ToAesonOptions '[] where toAesonOptions Proxy = defaultOptions 41 | instance (ToAesonOptionsField x, ToAesonOptions xs) => ToAesonOptions (x ': xs) where 42 | toAesonOptions Proxy = 43 | let 44 | patch = toAesonOptionsField (Proxy @x) 45 | opts = toAesonOptions (Proxy @xs) 46 | in 47 | patch $ defaultOptions 48 | { fieldLabelModifier = fieldLabelModifier opts 49 | , constructorTagModifier = constructorTagModifier opts 50 | , allNullaryToStringTag = allNullaryToStringTag opts 51 | , omitNothingFields = omitNothingFields opts 52 | , sumEncoding = sumEncoding opts 53 | , unwrapUnaryRecords = unwrapUnaryRecords opts 54 | , tagSingleConstructors = tagSingleConstructors opts 55 | } 56 | 57 | -- Its easy to get confusing errors if you forget to tick the list syntax. Hence the custom error 58 | instance TypeError ToAesonOptionsListError => ToAesonOptions [] where toAesonOptions = undefined 59 | instance TypeError ToAesonOptionsListError => ToAesonOptions [a] where toAesonOptions = undefined 60 | 61 | type ToAesonOptionsListError = 62 | ( 'Text "aeson-deriving constraint error for ToAesonOptions class:" 63 | ':$$: 'Text "Don't forget to \"tick\" your opening list bracket." 64 | ':$$: 'Text "There is no ToAesonOptions instance for list types." 65 | ':$$: 'Text "Rather, there are instances for promoted list values." 66 | ':$$: 'Text "" 67 | ':$$: 'Text "You likely should correct your deriving declaration to something like:" 68 | ':$$: 'Text "" 69 | ':$$: 'Text " via GenericEncoded '[myVal1,..]" 70 | ':$$: 'Text "" 71 | ':$$: 'Text "Instead of:" 72 | ':$$: 'Text "" 73 | ':$$: 'Text " via GenericEncoded [myVal1,..]" 74 | ':$$: 'Text "" 75 | ':$$: 'Text "For explanation, see GHC documentation on datatype promotion:" 76 | ':$$: 'Text "https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#datatype-promotion" 77 | ':$$: 'Text "" 78 | ) 79 | 80 | -- | A class that knows about fields of aeson's 'Options'. 81 | class ToAesonOptionsField x where 82 | toAesonOptionsField :: Proxy x -> Options -> Options 83 | 84 | -- | Represents an aeson 'Options' field to be set with `(:=)`. See `ToAesonOptions` 85 | data FieldLabelModifier 86 | -- | Represents an aeson 'Options' field to be set with `(:=)`. See `ToAesonOptions` 87 | data ConstructorTagModifier 88 | -- | Represents an aeson 'Options' field to be set with `(:=)`. See `ToAesonOptions` 89 | data AllNullaryToStringTag 90 | -- | Represents an aeson 'Options' field to be set with `(:=)`. See `ToAesonOptions` 91 | data OmitNothingFields 92 | 93 | -- SumEncoding type name already exists in aeson. We repurpose it. 94 | 95 | -- | Represents an aeson 'Options' field to be set with `(:=)`. See `ToAesonOptions` 96 | data UnwrapUnaryRecords 97 | -- | Represents an aeson 'Options' field to be set with `(:=)`. See `ToAesonOptions` 98 | data TagSingleConstructors 99 | 100 | instance StringFunction f => ToAesonOptionsField (FieldLabelModifier := f) where 101 | toAesonOptionsField Proxy opts = opts {fieldLabelModifier = stringFunction $ Proxy @f} 102 | instance StringFunction f => ToAesonOptionsField (ConstructorTagModifier := f) where 103 | toAesonOptionsField Proxy opts = opts {constructorTagModifier = stringFunction $ Proxy @f} 104 | instance KnownBool b => ToAesonOptionsField (AllNullaryToStringTag := b) where 105 | toAesonOptionsField Proxy opts = opts {allNullaryToStringTag = boolVal $ Proxy @b} 106 | instance KnownBool b => ToAesonOptionsField (OmitNothingFields := b) where 107 | toAesonOptionsField Proxy opts = opts {omitNothingFields = boolVal $ Proxy @b} 108 | instance ToSumEncoding se => ToAesonOptionsField (SumEncoding := se) where 109 | toAesonOptionsField Proxy opts = opts {sumEncoding = toSumEncoding $ Proxy @se} 110 | instance KnownBool b => ToAesonOptionsField (UnwrapUnaryRecords := b) where 111 | toAesonOptionsField Proxy opts = opts {unwrapUnaryRecords = boolVal $ Proxy @b} 112 | instance KnownBool b => ToAesonOptionsField (TagSingleConstructors := b) where 113 | toAesonOptionsField Proxy opts = opts {tagSingleConstructors = boolVal $ Proxy @b} 114 | 115 | 116 | ------------------------------------------------------------------------------------------ 117 | -- A Single type for all Options fields 118 | ------------------------------------------------------------------------------------------ 119 | 120 | -- | Type-level representation of the Aeson Generic deriving 'Options'. 121 | -- This representation is useful for explicitly setting all options. 122 | data GenericOptions 123 | :: fieldLabelModifier 124 | -> constructorTagModifier 125 | -> allNullaryToStringTag 126 | -> omitNothingFields 127 | -> sumEncoding 128 | -> unwrapUnaryRecords 129 | -> tagSingleConstructors 130 | -> Type 131 | 132 | instance 133 | ( All StringFunction [fieldLabelModifier, constructorTagModifier] 134 | , ToSumEncoding sumEncoding 135 | , All KnownBool 136 | [ allNullaryToStringTag 137 | , omitNothingFields 138 | , unwrapUnaryRecords 139 | , tagSingleConstructors 140 | ] 141 | ) => ToAesonOptions 142 | (GenericOptions 143 | (FieldLabelModifier := fieldLabelModifier) 144 | (ConstructorTagModifier := constructorTagModifier) 145 | (AllNullaryToStringTag := allNullaryToStringTag) 146 | (OmitNothingFields := omitNothingFields) 147 | (SumEncoding := sumEncoding) 148 | (UnwrapUnaryRecords := unwrapUnaryRecords) 149 | (TagSingleConstructors := tagSingleConstructors)) where 150 | toAesonOptions _ = defaultOptions 151 | { fieldLabelModifier = stringFunction $ Proxy @fieldLabelModifier 152 | , constructorTagModifier = stringFunction $ Proxy @constructorTagModifier 153 | , allNullaryToStringTag = boolVal $ Proxy @allNullaryToStringTag 154 | , omitNothingFields = boolVal $ Proxy @omitNothingFields 155 | , sumEncoding = toSumEncoding $ Proxy @sumEncoding 156 | , unwrapUnaryRecords = boolVal $ Proxy @unwrapUnaryRecords 157 | , tagSingleConstructors = boolVal $ Proxy @tagSingleConstructors 158 | } 159 | 160 | 161 | 162 | -- | Specify your encoding scheme in terms of aeson's out-of-the box Generic 163 | -- functionality. This type is never used directly, only "coerced through". 164 | -- Use some of the pre-defined types supplied here for the @opts@ phantom parameter, 165 | -- or define your with an instance of 'ToAesonOptions'. 166 | newtype GenericEncoded opts a = GenericEncoded a 167 | 168 | instance 169 | ( ToAesonOptions opts 170 | , Generic a 171 | , GFromJSON Zero (Rep a)) 172 | => FromJSON (GenericEncoded opts a) where 173 | parseJSON = fmap GenericEncoded . genericParseJSON (toAesonOptions $ Proxy @opts) 174 | 175 | instance 176 | ( ToAesonOptions opts 177 | , Generic a 178 | , GToJSON Zero (Rep a)) 179 | => ToJSON (GenericEncoded opts a) where 180 | toJSON (GenericEncoded x) 181 | = genericToJSON (toAesonOptions (Proxy @opts)) x 182 | 183 | -- | Used in FromJSON/ToJSON superclass constraints for newtypes that recursively modify 184 | -- the instances. A guard against the common mistake of deriving encoders in terms 185 | -- of such a newtype over the naked base type instead of the 'GenericEncoded' version. 186 | -- This can lead to nasty runtime bugs. 187 | -- 188 | -- This error can be disabled by wrapping your type in 'DisableLoopWarning'. 189 | -- This should never be necessary to use the functionality of this package. It may be 190 | -- required if you, for example, combine our newtypes with another library's types 191 | -- for generating aeson instances. 192 | type family LoopWarning (n :: Type -> Type) (a :: Type) :: Constraint where 193 | LoopWarning n (GenericEncoded opts a) = () 194 | LoopWarning n (RecordSumEncoded tagKey tagValMod a) = () 195 | LoopWarning n (EmptyObject a) = () 196 | LoopWarning n (DisableLoopWarning a) = () 197 | LoopWarning n (x & f) = LoopWarning n (f x) 198 | LoopWarning n (f x) = LoopWarning n x 199 | LoopWarning n x = TypeError 200 | ( 'Text "Uh oh! Watch out for those infinite loops!" 201 | ':$$: 'Text "Newtypes that recursively modify aeson instances, namely:" 202 | ':$$: 'Text "" 203 | ':$$: 'Text " " ':<>: 'ShowType n 204 | ':$$: 'Text "" 205 | ':$$: 'Text "must only be used atop a type that creates the instances non-recursively: " 206 | ':$$: 'Text "" 207 | ':$$: 'Text " ￮ GenericEncoded" 208 | ':$$: 'Text " ￮ RecordSumEncoded" 209 | ':$$: 'Text "" 210 | ':$$: 'Text "We observe instead the inner type: " 211 | ':$$: 'Text "" 212 | ':$$: 'Text " " ':<>: 'ShowType x 213 | ':$$: 'Text "" 214 | ':$$: 'Text "You probably created an infinitely recursive encoder/decoder pair." 215 | ':$$: 'Text "See `LoopWarning` for details." 216 | ':$$: 'Text "This check can be disabled by wrapping the inner type in `DisableLoopWarning`." 217 | ':$$: 'Text "" 218 | ) 219 | 220 | -- | Assert that you know what you're doing and to nullify the 'LoopWarning' constraint 221 | -- family. This should not be necessary. 222 | newtype DisableLoopWarning a = DisableLoopWarning a 223 | deriving newtype (FromJSON, ToJSON) 224 | 225 | ------------------------------------------------------------------------------------------ 226 | -- Sums over records 227 | ------------------------------------------------------------------------------------------ 228 | 229 | -- | An encoding scheme for sums of records that are defined as distinct data types. 230 | -- If we have a number of record types we want to combine under a sum, a straightforward 231 | -- solution is to ensure that each each inner type uses a constructor tag, and then 232 | -- derive the sum with @SumEncoding := UntaggedValue@. This works fine for the happy 233 | -- path, but makes for very bad error messages, since it means that decoding proceeds by 234 | -- trying each case in sequence. Thus error messages always pertain to the last type in 235 | -- the sum, even when it wasn't the intended payload. This newtype improves on that 236 | -- solution by providing the relevant error messages, by remembering the correspondence 237 | -- between the constructor tag and the intended inner type/parser. 238 | -- 239 | -- In order to work correctly, the inner types must use the 'TaggedObject' encoding. 240 | -- The same tag field name and 'ConstructorTagModifier' must be supplied to this type. 241 | newtype RecordSumEncoded (tagKey :: Symbol) (tagModifier :: k) (a :: Type) = RecordSumEncoded a 242 | 243 | instance 244 | ( Generic a 245 | , GFromJSON Zero (Rep a) 246 | , GTagParserMap (Rep a) 247 | , Rep a ~ D1 meta cs 248 | , Datatype meta 249 | , StringFunction tagModifier 250 | , KnownSymbol tagKey) 251 | => FromJSON (RecordSumEncoded tagKey tagModifier a) where 252 | parseJSON val = prependErrMsg outerErrorMsg . flip (withObject "Object") val $ \hm -> do 253 | tagVal <- hm .: pack tagKeyStr 254 | case HashMap.lookup tagVal parserMap of 255 | Nothing -> fail . mconcat $ 256 | [ "We are not expecting a payload with tag value " <> backticks tagVal 257 | , " under the " <> backticks tagKeyStr <> " key here. " 258 | , "Expected tag values: " 259 | , intercalate ", " $ backticks <$> HashMap.keys parserMap 260 | , "." 261 | ] 262 | Just parser -> RecordSumEncoded . to <$> parser val 263 | & prependErrMsg 264 | ("Failed parsing the case with tag value " 265 | <> backticks tagVal <> " under the " 266 | <> backticks tagKeyStr <> " key: ") 267 | 268 | where 269 | tagKeyStr = symbolVal $ Proxy @tagKey 270 | ParserMap parserMap 271 | = unsafeMapKeys (stringFunction $ Proxy @tagModifier) 272 | . gParserMap 273 | $ Proxy @(Rep a) 274 | backticks str = "`" <> str <> "`" 275 | prependErrMsg str = modifyFailure (str <>) 276 | outerErrorMsg = "Failed to parse a " <> datatypeName @meta undefined <> ": " 277 | 278 | 279 | instance 280 | ( Generic a 281 | , GToJSON Zero (Rep a)) 282 | => ToJSON (RecordSumEncoded tagKey tagModifier a) where 283 | toJSON (RecordSumEncoded x) = 284 | toJSON $ GenericEncoded @'[SumEncoding := UntaggedValue] x 285 | 286 | 287 | 288 | ------------------------------------------------------------------------------------------ 289 | -- String functions 290 | ------------------------------------------------------------------------------------------ 291 | 292 | stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] 293 | stripSuffix a b = reverse <$> stripPrefix (reverse a) (reverse b) 294 | 295 | dropPrefix :: Eq a => [a] -> [a] -> [a] 296 | dropPrefix a b = fromMaybe b $ stripPrefix a b 297 | 298 | dropSuffix :: Eq a => [a] -> [a] -> [a] 299 | dropSuffix a b = fromMaybe b $ stripSuffix a b 300 | 301 | class StringFunction (a :: k) where 302 | stringFunction :: Proxy a -> String -> String 303 | 304 | data Id 305 | -- | Applies 'snakeCase' 306 | data SnakeCase 307 | data Uppercase 308 | data Lowercase 309 | data FirstChar a 310 | -- | Applies 'dropLowercasePrefix', dropping until the first uppercase character. 311 | data DropLowercasePrefix 312 | data DropPrefix (str :: Symbol) 313 | data DropSuffix (str :: Symbol) 314 | 315 | instance StringFunction Id where stringFunction _ = id 316 | instance StringFunction SnakeCase where stringFunction _ = snakeCase 317 | instance StringFunction Uppercase where stringFunction _ = map toUpper 318 | instance StringFunction Lowercase where stringFunction _ = map toLower 319 | instance StringFunction DropLowercasePrefix where stringFunction _ = dropLowercasePrefix 320 | 321 | instance KnownSymbol str => StringFunction (DropPrefix str) where 322 | stringFunction Proxy = dropPrefix (symbolVal $ Proxy @str) 323 | instance KnownSymbol str => StringFunction (DropSuffix str) where 324 | stringFunction Proxy = dropSuffix (symbolVal $ Proxy @str) 325 | 326 | instance StringFunction '[] where stringFunction _ = id 327 | instance (StringFunction x, StringFunction xs) => StringFunction (x ': xs) where 328 | stringFunction Proxy = stringFunction (Proxy @x) . stringFunction (Proxy @xs) 329 | 330 | instance All KnownSymbol [a, b] => StringFunction (a ==> b) where 331 | stringFunction Proxy x 332 | | x == symbolVal (Proxy @a) = symbolVal (Proxy @b) 333 | | otherwise = x 334 | 335 | instance StringFunction a => StringFunction (FirstChar a) where 336 | stringFunction Proxy = \case 337 | [] -> [] 338 | c:cs -> stringFunction (Proxy @a) [c] ++ cs 339 | 340 | ------------------------------------------------------------------------------------------ 341 | -- Sum type encodings 342 | ------------------------------------------------------------------------------------------ 343 | 344 | -- | Type-level encoding for 'SumEncoding' 345 | class ToSumEncoding a where 346 | toSumEncoding :: Proxy a -> SumEncoding 347 | 348 | data UntaggedValue 349 | data ObjectWithSingleField 350 | data TwoElemArray 351 | 352 | -- | A constructor will be encoded to an object with a field tagFieldName which specifies 353 | -- the constructor tag (modified by the constructorTagModifier). If the constructor is 354 | -- a record the encoded record fields will be unpacked into this object. So make sure 355 | -- that your record doesn't have a field with the same label as the tagFieldName. 356 | -- Otherwise the tag gets overwritten by the encoded value of that field! If the 357 | -- constructor is not a record the encoded constructor contents will be stored under 358 | -- the contentsFieldName field. 359 | data TaggedObject (tagFieldName :: Symbol) (contentsFieldName :: Symbol) 360 | -- Would be nice to have separate types for records versus ordinary constructors 361 | -- rather than conflating them with the conditional interpretation of this type. 362 | -- However, this module is just about modeling what aeson gives us. 363 | 364 | instance ToSumEncoding UntaggedValue where toSumEncoding _ = UntaggedValue 365 | instance ToSumEncoding ObjectWithSingleField where toSumEncoding _ = ObjectWithSingleField 366 | instance ToSumEncoding TwoElemArray where toSumEncoding _ = TwoElemArray 367 | instance (KnownSymbol tag, KnownSymbol contents) => ToSumEncoding (TaggedObject tag contents) where 368 | toSumEncoding _ = TaggedObject 369 | (symbolVal $ Proxy @tag) 370 | (symbolVal $ Proxy @contents) 371 | 372 | 373 | ------------------------------------------------------------------------------------------ 374 | -- Utilities 375 | ------------------------------------------------------------------------------------------ 376 | 377 | -- | Field name modifier function that separates camel-case words by underscores 378 | -- (i.e. on capital letters). Also knows to handle a consecutive sequence of 379 | -- capitals as a single word. 380 | snakeCase :: String -> String 381 | snakeCase = camelTo2 '_' 382 | 383 | -- | Drop the first lowercase sequence (i.e. until 'isUpper' returns True) from the start 384 | -- of a string. Used for the common idiom where fields are prefixed by the type name in 385 | -- all lowercase. The definition is taken from the aeson-casing package. 386 | dropLowercasePrefix :: String -> String 387 | dropLowercasePrefix [] = [] 388 | dropLowercasePrefix (x:xs) 389 | | isUpper x = x : xs 390 | | otherwise = dropLowercasePrefix xs 391 | 392 | infixl 2 & 393 | 394 | newtype (x & f) = Ampersand {unAmpersand :: f x } 395 | deriving newtype (FromJSON, ToJSON) 396 | --------------------------------------------------------------------------------