{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-}
module Deriving.Aeson
( CustomJSON(..)
, FieldLabelModifier
, ConstructorTagModifier
, OmitNothingFields
, RejectUnknownFields
, TagSingleConstructors
, NoAllNullaryToStringTag
, UnwrapUnaryRecords
, SumTaggedObject
, SumUntaggedValue
, SumObjectWithSingleField
, SumTwoElemArray
, StripPrefix
, CamelToKebab
, CamelToSnake
, AesonOptions(..)
, StringModifier(..)
, FromJSON
, ToJSON
, Generic
)where
import Data.Aeson
import Data.Aeson.Types
import Data.Coerce
import Data.List (stripPrefix)
import Data.Maybe (fromMaybe)
import Data.Proxy
import GHC.Generics
import GHC.TypeLits
newtype CustomJSON t a = CustomJSON { unCustomJSON :: a }
instance (AesonOptions t, Generic a, GFromJSON Zero (Rep a)) => FromJSON (CustomJSON t a) where
parseJSON = (coerce `asTypeOf` fmap CustomJSON) . genericParseJSON (aesonOptions @t)
{-# INLINE parseJSON #-}
instance (AesonOptions t, Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (CustomJSON t a) where
toJSON = genericToJSON (aesonOptions @t) . unCustomJSON
{-# INLINE toJSON #-}
toEncoding = genericToEncoding (aesonOptions @t) . unCustomJSON
{-# INLINE toEncoding #-}
data FieldLabelModifier t
data ConstructorTagModifier t
data OmitNothingFields
data RejectUnknownFields
data TagSingleConstructors
data NoAllNullaryToStringTag
data UnwrapUnaryRecords
data StripPrefix t
data CamelToSnake
data CamelToKebab
class StringModifier t where
getStringModifier :: String -> String
instance KnownSymbol k => StringModifier (StripPrefix k) where
getStringModifier = fromMaybe <*> stripPrefix (symbolVal (Proxy @k))
instance (StringModifier a, StringModifier b) => StringModifier (a, b) where
getStringModifier = getStringModifier @b . getStringModifier @a
instance StringModifier CamelToKebab where
getStringModifier = camelTo2 '-'
instance StringModifier CamelToSnake where
getStringModifier = camelTo2 '_'
data SumTaggedObject t c
data SumUntaggedValue
data SumObjectWithSingleField
data SumTwoElemArray
class AesonOptions xs where
aesonOptions :: Options
instance AesonOptions '[] where
aesonOptions = defaultOptions
instance AesonOptions xs => AesonOptions (UnwrapUnaryRecords ': xs) where
aesonOptions = (aesonOptions @xs) { unwrapUnaryRecords = True }
instance AesonOptions xs => AesonOptions (OmitNothingFields ': xs) where
aesonOptions = (aesonOptions @xs) { omitNothingFields = True }
instance AesonOptions xs => AesonOptions (RejectUnknownFields ': xs) where
aesonOptions = (aesonOptions @xs) { rejectUnknownFields = True }
instance (StringModifier f, AesonOptions xs) => AesonOptions (FieldLabelModifier f ': xs) where
aesonOptions = (aesonOptions @xs) { fieldLabelModifier = getStringModifier @f }
instance (StringModifier f, AesonOptions xs) => AesonOptions (ConstructorTagModifier f ': xs) where
aesonOptions = (aesonOptions @xs) { constructorTagModifier = getStringModifier @f }
instance AesonOptions xs => AesonOptions (TagSingleConstructors ': xs) where
aesonOptions = (aesonOptions @xs) { tagSingleConstructors = True }
instance AesonOptions xs => AesonOptions (NoAllNullaryToStringTag ': xs) where
aesonOptions = (aesonOptions @xs) { allNullaryToStringTag = False }
instance (KnownSymbol t, KnownSymbol c, AesonOptions xs) => AesonOptions (SumTaggedObject t c ': xs) where
aesonOptions = (aesonOptions @xs) { sumEncoding = TaggedObject (symbolVal (Proxy @ t)) (symbolVal (Proxy @ c)) }
instance (AesonOptions xs) => AesonOptions (SumUntaggedValue ': xs) where
aesonOptions = (aesonOptions @xs) { sumEncoding = UntaggedValue }
instance (AesonOptions xs) => AesonOptions (SumObjectWithSingleField ': xs) where
aesonOptions = (aesonOptions @xs) { sumEncoding = ObjectWithSingleField }
instance (AesonOptions xs) => AesonOptions (SumTwoElemArray ': xs) where
aesonOptions = (aesonOptions @xs) { sumEncoding = ObjectWithSingleField }