{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.Deriving.Internal.Decode.Rep ( DecodeRep (..), ) where import Control.Monad.Except (MonadError (throwError)) import Data.Morpheus.Server.Deriving.Internal.Decode.Utils ( Context (..), CountFields (..), DecoderT, DescribeCons, decodeFieldWith, getFieldName, getUnionInfos, setVariantRef, withInputObject, withInputUnion, ) import Data.Morpheus.Server.Deriving.Utils.Proxy ( selNameProxy, ) import Data.Morpheus.Server.Deriving.Utils.Use ( UseDeriving (..), UseValue (..), ) import Data.Morpheus.Types.Internal.AST ( Object, TypeName, VALID, ValidObject, ValidValue, Value (..), internal, msg, ) import GHC.Generics import Relude decideEither :: (DecodeRep gql args f, DecodeRep gql args g) => UseDeriving gql args -> ([TypeName], [TypeName]) -> TypeName -> ValidValue -> DecoderT ((f :+: g) a) decideEither :: forall (gql :: * -> Constraint) (args :: * -> Constraint) (f :: * -> *) (g :: * -> *) a. (DecodeRep gql args f, DecodeRep gql args g) => UseDeriving gql args -> ([TypeName], [TypeName]) -> TypeName -> ValidValue -> DecoderT ((:+:) f g a) decideEither UseDeriving gql args dir ([TypeName] left, [TypeName] right) TypeName name ValidValue value | TypeName name forall (f :: * -> *) a. (Foldable f, DisallowElem f, Eq a) => a -> f a -> Bool `elem` [TypeName] left = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (gql :: * -> Constraint) (args :: * -> Constraint) (f :: * -> *) a. DecodeRep gql args f => UseDeriving gql args -> ValidValue -> DecoderT (f a) decodeRep UseDeriving gql args dir ValidValue value | TypeName name forall (f :: * -> *) a. (Foldable f, DisallowElem f, Eq a) => a -> f a -> Bool `elem` [TypeName] right = forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (gql :: * -> Constraint) (args :: * -> Constraint) (f :: * -> *) a. DecodeRep gql args f => UseDeriving gql args -> ValidValue -> DecoderT (f a) decodeRep UseDeriving gql args dir ValidValue value | Bool otherwise = forall e (m :: * -> *) a. MonadError e m => e -> m a throwError forall a b. (a -> b) -> a -> b $ GQLError -> GQLError internal forall a b. (a -> b) -> a -> b $ GQLError "Constructor \"" forall a. Semigroup a => a -> a -> a <> forall a. Msg a => a -> GQLError msg TypeName name forall a. Semigroup a => a -> a -> a <> GQLError "\" could not find in Union" decodeInputUnionObject :: (DecodeRep gql args f, DecodeRep gql args g) => UseDeriving gql args -> ([TypeName], [TypeName]) -> TypeName -> Object VALID -> ValidObject -> DecoderT ((f :+: g) a) decodeInputUnionObject :: forall (gql :: * -> Constraint) (args :: * -> Constraint) (f :: * -> *) (g :: * -> *) a. (DecodeRep gql args f, DecodeRep gql args g) => UseDeriving gql args -> ([TypeName], [TypeName]) -> TypeName -> Object VALID -> Object VALID -> DecoderT ((:+:) f g a) decodeInputUnionObject UseDeriving gql args dir ([TypeName] l, [TypeName] r) TypeName name Object VALID unions Object VALID object | [TypeName name] forall a. Eq a => a -> a -> Bool == [TypeName] l = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (gql :: * -> Constraint) (args :: * -> Constraint) (f :: * -> *) a. DecodeRep gql args f => UseDeriving gql args -> ValidValue -> DecoderT (f a) decodeRep UseDeriving gql args dir (forall (stage :: Stage). Object stage -> Value stage Object Object VALID object) | [TypeName name] forall a. Eq a => a -> a -> Bool == [TypeName] r = forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (gql :: * -> Constraint) (args :: * -> Constraint) (f :: * -> *) a. DecodeRep gql args f => UseDeriving gql args -> ValidValue -> DecoderT (f a) decodeRep UseDeriving gql args dir (forall (stage :: Stage). Object stage -> Value stage Object Object VALID object) | Bool otherwise = forall (gql :: * -> Constraint) (args :: * -> Constraint) (f :: * -> *) (g :: * -> *) a. (DecodeRep gql args f, DecodeRep gql args g) => UseDeriving gql args -> ([TypeName], [TypeName]) -> TypeName -> ValidValue -> DecoderT ((:+:) f g a) decideEither UseDeriving gql args dir ([TypeName] l, [TypeName] r) TypeName name (forall (stage :: Stage). Object stage -> Value stage Object Object VALID unions) class DecodeRep gql args (f :: Type -> Type) where decodeRep :: UseDeriving gql args -> ValidValue -> DecoderT (f a) instance (Datatype d, DecodeRep gql args f) => DecodeRep gql args (M1 D d f) where decodeRep :: forall a. UseDeriving gql args -> ValidValue -> DecoderT (M1 D d f a) decodeRep UseDeriving gql args dir ValidValue value = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (gql :: * -> Constraint) (args :: * -> Constraint) (f :: * -> *) a. DecodeRep gql args f => UseDeriving gql args -> ValidValue -> DecoderT (f a) decodeRep UseDeriving gql args dir ValidValue value instance (DescribeCons gql a, DescribeCons gql b, DecodeRep gql args a, DecodeRep gql args b) => DecodeRep gql args (a :+: b) where decodeRep :: forall a. UseDeriving gql args -> ValidValue -> DecoderT ((:+:) a b a) decodeRep UseDeriving gql args dir (Object Object VALID obj) = do (Bool kind, ([TypeName], [TypeName]) lr) <- forall (f :: (* -> *) -> *) (a :: * -> *) (b :: * -> *) (gql :: * -> Constraint). (DescribeCons gql a, DescribeCons gql b) => UseGQLType gql -> f (a :+: b) -> DecoderT (Bool, ([TypeName], [TypeName])) getUnionInfos (forall (gql :: * -> Constraint) (val :: * -> Constraint). UseDeriving gql val -> UseGQLType gql dirGQL UseDeriving gql args dir) (forall {k} (t :: k). Proxy t Proxy @(a :+: b)) forall a. Bool -> DecoderT a -> DecoderT a setVariantRef Bool kind forall a b. (a -> b) -> a -> b $ forall (m :: * -> *) a. (MonadError GQLError m, Monad m) => (TypeName -> Object VALID -> Object VALID -> m a) -> Object VALID -> m a withInputUnion (forall (gql :: * -> Constraint) (args :: * -> Constraint) (f :: * -> *) (g :: * -> *) a. (DecodeRep gql args f, DecodeRep gql args g) => UseDeriving gql args -> ([TypeName], [TypeName]) -> TypeName -> Object VALID -> Object VALID -> DecoderT ((:+:) f g a) decodeInputUnionObject UseDeriving gql args dir ([TypeName], [TypeName]) lr) Object VALID obj decodeRep UseDeriving gql args dir (Enum TypeName name) = do (Bool _, ([TypeName] l, [TypeName] r)) <- forall (f :: (* -> *) -> *) (a :: * -> *) (b :: * -> *) (gql :: * -> Constraint). (DescribeCons gql a, DescribeCons gql b) => UseGQLType gql -> f (a :+: b) -> DecoderT (Bool, ([TypeName], [TypeName])) getUnionInfos (forall (gql :: * -> Constraint) (val :: * -> Constraint). UseDeriving gql val -> UseGQLType gql dirGQL UseDeriving gql args dir) (forall {k} (t :: k). Proxy t Proxy @(a :+: b)) TypeName -> TypeName visitor <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a asks Context -> TypeName -> TypeName enumVisitor forall (gql :: * -> Constraint) (args :: * -> Constraint) (f :: * -> *) (g :: * -> *) a. (DecodeRep gql args f, DecodeRep gql args g) => UseDeriving gql args -> ([TypeName], [TypeName]) -> TypeName -> ValidValue -> DecoderT ((:+:) f g a) decideEither UseDeriving gql args dir (forall a b. (a -> b) -> [a] -> [b] map TypeName -> TypeName visitor [TypeName] l, forall a b. (a -> b) -> [a] -> [b] map TypeName -> TypeName visitor [TypeName] r) TypeName name (forall (stage :: Stage). TypeName -> Value stage Enum TypeName name) decodeRep UseDeriving gql args _ ValidValue _ = forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (GQLError -> GQLError internal GQLError "lists and scalars are not allowed in Union") instance (Constructor c, DecodeFields gql args a) => DecodeRep gql args (M1 C c a) where decodeRep :: forall a. UseDeriving gql args -> ValidValue -> DecoderT (M1 C c a a) decodeRep UseDeriving gql args dir = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p M1 forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (gql :: * -> Constraint) (args :: * -> Constraint) (f :: * -> *) a. DecodeFields gql args f => UseDeriving gql args -> Int -> ValidValue -> DecoderT (f a) decodeFields UseDeriving gql args dir Int 0 class DecodeFields gql args (f :: Type -> Type) where decodeFields :: UseDeriving gql args -> Int -> ValidValue -> DecoderT (f a) instance (DecodeFields gql args f, DecodeFields gql args g, CountFields g) => DecodeFields gql args (f :*: g) where decodeFields :: forall a. UseDeriving gql args -> Int -> ValidValue -> DecoderT ((:*:) f g a) decodeFields UseDeriving gql args dir Int index ValidValue gql = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> g p -> (:*:) f g p (:*:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (gql :: * -> Constraint) (args :: * -> Constraint) (f :: * -> *) a. DecodeFields gql args f => UseDeriving gql args -> Int -> ValidValue -> DecoderT (f a) decodeFields UseDeriving gql args dir Int index ValidValue gql forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall (gql :: * -> Constraint) (args :: * -> Constraint) (f :: * -> *) a. DecodeFields gql args f => UseDeriving gql args -> Int -> ValidValue -> DecoderT (f a) decodeFields UseDeriving gql args dir (Int index forall a. Num a => a -> a -> a + forall (f :: * -> *). CountFields f => Proxy f -> Int countFields (forall {k} (t :: k). Proxy t Proxy @g)) ValidValue gql instance (Selector s, args a) => DecodeFields gql args (M1 S s (K1 i a)) where decodeFields :: forall a. UseDeriving gql args -> Int -> ValidValue -> DecoderT (M1 S s (K1 i a) a) decodeFields UseDeriving {UseValue args dirArgs :: forall (gql :: * -> Constraint) (val :: * -> Constraint). UseDeriving gql val -> UseValue val dirArgs :: UseValue args dirArgs} Int index ValidValue value = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p M1 forall b c a. (b -> c) -> (a -> b) -> a -> c . forall k i c (p :: k). c -> K1 i c p K1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> do Context {Bool isVariantRef :: Context -> Bool isVariantRef :: Bool isVariantRef, FieldName -> FieldName fieldVisitor :: Context -> FieldName -> FieldName fieldVisitor :: FieldName -> FieldName fieldVisitor} <- forall r (m :: * -> *). MonadReader r m => m r ask if Bool isVariantRef then forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (forall (val :: * -> Constraint). UseValue val -> forall a. val a => ValidValue -> ResolverState a useDecodeValue UseValue args dirArgs ValidValue value) else let fieldName :: FieldName fieldName = FieldName -> FieldName fieldVisitor forall a b. (a -> b) -> a -> b $ FieldName -> Int -> FieldName getFieldName (forall (f :: Meta -> *) (s :: Meta). Selector s => f s -> FieldName selNameProxy (forall {k} (t :: k). Proxy t Proxy @s)) Int index fieldDecoder :: Object VALID -> ReaderT Context ResolverState a fieldDecoder = forall (m :: * -> *) a. (ValidValue -> m a) -> FieldName -> Object VALID -> m a decodeFieldWith (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (val :: * -> Constraint). UseValue val -> forall a. val a => ValidValue -> ResolverState a useDecodeValue UseValue args dirArgs) FieldName fieldName in forall (m :: * -> *) a. MonadError GQLError m => (Object VALID -> m a) -> ValidValue -> m a withInputObject Object VALID -> ReaderT Context ResolverState a fieldDecoder ValidValue value instance DecodeFields gql args U1 where decodeFields :: forall a. UseDeriving gql args -> Int -> ValidValue -> DecoderT (U1 a) decodeFields UseDeriving gql args _ Int _ ValidValue _ = forall (f :: * -> *) a. Applicative f => a -> f a pure forall k (p :: k). U1 p U1