diff options
Diffstat (limited to 'users/grfn/xanthous/src/Data/Aeson/Generic/DerivingVia.hs')
-rw-r--r-- | users/grfn/xanthous/src/Data/Aeson/Generic/DerivingVia.hs | 168 |
1 files changed, 0 insertions, 168 deletions
diff --git a/users/grfn/xanthous/src/Data/Aeson/Generic/DerivingVia.hs b/users/grfn/xanthous/src/Data/Aeson/Generic/DerivingVia.hs deleted file mode 100644 index e89fcd621157..000000000000 --- a/users/grfn/xanthous/src/Data/Aeson/Generic/DerivingVia.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, DeriveGeneric, DerivingVia #-} -{-# LANGUAGE ExplicitNamespaces, FlexibleContexts, FlexibleInstances #-} -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds, ScopedTypeVariables, StandaloneDeriving #-} -{-# LANGUAGE TypeApplications, TypeFamilies, TypeInType, TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall #-} --- | https://gist.github.com/konn/27c00f784dd883ec2b90eab8bc84a81d -module Data.Aeson.Generic.DerivingVia - ( StrFun(..), Setting(..), SumEncoding'(..), DefaultOptions, WithOptions(..) - , -- Utility type synonyms to save ticks (') before promoted data constructors - type Drop, type CamelTo2, type UserDefined - , type TaggedObj, type UntaggedVal, type ObjWithSingleField, type TwoElemArr - , type FieldLabelModifier - , type ConstructorTagModifier - , type AllNullaryToStringTag - , type OmitNothingFields - , type SumEnc - , type UnwrapUnaryRecords - , type TagSingleConstructors - ) - where - -import Prelude -import Data.Aeson (FromJSON (..), GFromJSON, GToJSON, - ToJSON (..)) -import Data.Aeson (Options (..), Zero, camelTo2, - genericParseJSON) -import Data.Aeson (defaultOptions, genericToJSON) -import qualified Data.Aeson as Aeson -import Data.Kind (Constraint, Type) -import Data.Proxy (Proxy (..)) -import Data.Reflection (Reifies (..)) -import GHC.Generics (Generic, Rep) -import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal) -import GHC.TypeLits (Nat, Symbol) - -newtype WithOptions options a = WithOptions { runWithOptions :: a } - -data StrFun = Drop Nat - | CamelTo2 Symbol - | forall p. UserDefined p - -type Drop = 'Drop -type CamelTo2 = 'CamelTo2 -type UserDefined = 'UserDefined - -type family Demoted a where - Demoted Symbol = String - Demoted StrFun = String -> String - Demoted [a] = [Demoted a] - Demoted Setting = Options -> Options - Demoted SumEncoding' = Aeson.SumEncoding - Demoted a = a - -data SumEncoding' = TaggedObj {tagFieldName' :: Symbol, contentsFieldName :: Symbol } - | UntaggedVal - | ObjWithSingleField - | TwoElemArr - -type TaggedObj = 'TaggedObj -type UntaggedVal = 'UntaggedVal -type ObjWithSingleField = 'ObjWithSingleField -type TwoElemArr = 'TwoElemArr - -data Setting = FieldLabelModifier [StrFun] - | ConstructorTagModifier [StrFun] - | AllNullaryToStringTag Bool - | OmitNothingFields Bool - | SumEnc SumEncoding' - | UnwrapUnaryRecords Bool - | TagSingleConstructors Bool - -type FieldLabelModifier = 'FieldLabelModifier -type ConstructorTagModifier = 'ConstructorTagModifier --- | If 'True' the constructors of a datatype, with all nullary constructors, --- will be encoded to just a string with the constructor tag. If 'False' the --- encoding will always follow the 'SumEncoding'. -type AllNullaryToStringTag = 'AllNullaryToStringTag -type OmitNothingFields = 'OmitNothingFields -type SumEnc = 'SumEnc --- | Hide the field name when a record constructor has only one field, like a --- newtype. -type UnwrapUnaryRecords = 'UnwrapUnaryRecords --- | Encode types with a single constructor as sums, so that --- 'AllNullaryToStringTag' and 'SumEncoding' apply. -type TagSingleConstructors = 'TagSingleConstructors - -class Demotable (a :: k) where - demote :: proxy a -> Demoted k - -type All :: (Type -> Constraint) -> [Type] -> Constraint -type family All p xs where - All p '[] = () - All p (x ': xs) = (p x, All p xs) - -instance Reifies f (String -> String) => Demotable ('UserDefined f) where - demote _ = reflect @f Proxy - -instance KnownSymbol sym => Demotable sym where - demote = symbolVal - -instance (KnownSymbol s, KnownSymbol t) => Demotable ('TaggedObj s t) where - demote _ = Aeson.TaggedObject (symbolVal @s Proxy) (symbolVal @t Proxy) - -instance Demotable 'UntaggedVal where - demote _ = Aeson.UntaggedValue - -instance Demotable 'ObjWithSingleField where - demote _ = Aeson.ObjectWithSingleField - -instance Demotable 'TwoElemArr where - demote _ = Aeson.TwoElemArray - -instance Demotable xs => Demotable ('FieldLabelModifier xs) where - demote _ o = o { fieldLabelModifier = foldr (.) id (demote (Proxy @xs)) } - -instance Demotable xs => Demotable ('ConstructorTagModifier xs) where - demote _ o = o { constructorTagModifier = foldr (.) id (demote (Proxy @xs)) } - -instance Demotable b => Demotable ('AllNullaryToStringTag b) where - demote _ o = o { allNullaryToStringTag = demote (Proxy @b) } - -instance Demotable b => Demotable ('OmitNothingFields b) where - demote _ o = o { omitNothingFields = demote (Proxy @b) } - -instance Demotable b => Demotable ('UnwrapUnaryRecords b) where - demote _ o = o { unwrapUnaryRecords = demote (Proxy @b) } - -instance Demotable b => Demotable ('TagSingleConstructors b) where - demote _ o = o { tagSingleConstructors = demote (Proxy @b) } - -instance Demotable b => Demotable ('SumEnc b) where - demote _ o = o { sumEncoding = demote (Proxy @b) } - -instance Demotable 'True where - demote _ = True - -instance Demotable 'False where - demote _ = False - -instance KnownNat n => Demotable ('Drop n) where - demote _ = drop (fromIntegral $ natVal (Proxy :: Proxy n)) - -instance KnownSymbol sym => Demotable ('CamelTo2 sym) where - demote _ = camelTo2 $ head $ symbolVal @sym Proxy - -instance {-# OVERLAPPING #-} Demotable ('[] :: [k]) where - demote _ = [] - -instance (Demotable (x :: k), Demotable (xs :: [k])) => Demotable (x ': xs) where - demote _ = demote (Proxy @x) : demote (Proxy @xs) - -type DefaultOptions = ('[] :: [Setting]) - -reflectOptions :: forall xs proxy. Demotable (xs :: [Setting]) => proxy xs -> Options -reflectOptions pxy = foldr (.) id (demote pxy) defaultOptions - -instance (Demotable (options :: [Setting])) => Reifies options Options where - reflect = reflectOptions - -instance (Generic a, GToJSON Zero (Rep a), Reifies (options :: k) Options) - => ToJSON (WithOptions options a) where - toJSON = genericToJSON (reflect (Proxy @options)) . runWithOptions - -instance (Generic a, GFromJSON Zero (Rep a), Reifies (options :: k) Options) - => FromJSON (WithOptions options a) where - parseJSON = fmap WithOptions . genericParseJSON (reflect (Proxy @options)) |