{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Server.Deriving.Decode
( decodeArguments,
Decode (..),
DecodeConstraint,
)
where
import Control.Monad.Except (MonadError (throwError))
import qualified Data.Map as M
import Data.Morpheus.App.Internal.Resolving
( ResolverState,
)
import Data.Morpheus.Kind
( CUSTOM,
DerivingKind,
SCALAR,
TYPE,
WRAPPER,
)
import Data.Morpheus.Server.Deriving.Utils
( conNameProxy,
selNameProxy,
symbolName,
)
import Data.Morpheus.Server.Deriving.Utils.Decode
( decodeFieldWith,
handleEither,
withInputObject,
withInputUnion,
withScalar,
)
import Data.Morpheus.Server.Deriving.Utils.Kinded
( KindedProxy (..),
)
import Data.Morpheus.Server.Types.GQLType
( GQLType
( KIND,
typeOptions
),
GQLTypeOptions (..),
TypeData (..),
__typeData,
defaultTypeOptions,
)
import Data.Morpheus.Server.Types.Types (Arg (Arg))
import Data.Morpheus.Types.GQLScalar
( DecodeScalar (..),
)
import Data.Morpheus.Types.GQLWrapper
( DecodeWrapper (..),
DecodeWrapperConstraint,
)
import Data.Morpheus.Types.Internal.AST
( Argument (..),
Arguments,
FieldName,
GQLError,
IN,
LEAF,
Object,
ObjectEntry (..),
TypeName,
VALID,
ValidObject,
ValidValue,
Value (..),
internal,
msg,
)
import GHC.Generics
import GHC.TypeLits (KnownSymbol)
import Relude
type DecodeConstraint a = (DecodeKind (KIND a) a)
decodeArguments :: forall a. DecodeConstraint a => Arguments VALID -> ResolverState a
decodeArguments :: Arguments VALID -> ResolverState a
decodeArguments = Proxy (KIND a) -> ValidValue -> ResolverState a
forall (kind :: DerivingKind) a.
DecodeKind kind a =>
Proxy kind -> ValidValue -> ResolverState a
decodeKind (Proxy (KIND a)
forall k (t :: k). Proxy t
Proxy @(KIND a)) (ValidValue -> ResolverState a)
-> (Arguments VALID -> ValidValue)
-> Arguments VALID
-> ResolverState a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object VALID -> ValidValue
forall (stage :: Stage). Object stage -> Value stage
Object (Object VALID -> ValidValue)
-> (Arguments VALID -> Object VALID)
-> Arguments VALID
-> ValidValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Argument VALID -> ObjectEntry VALID)
-> Arguments VALID -> Object VALID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Argument VALID -> ObjectEntry VALID
forall (s :: Stage). Argument s -> ObjectEntry s
toEntry
where
toEntry :: Argument s -> ObjectEntry s
toEntry Argument {Value s
FieldName
Position
argumentPosition :: forall (valid :: Stage). Argument valid -> Position
argumentName :: forall (valid :: Stage). Argument valid -> FieldName
argumentValue :: forall (valid :: Stage). Argument valid -> Value valid
argumentValue :: Value s
argumentName :: FieldName
argumentPosition :: Position
..} = FieldName -> Value s -> ObjectEntry s
forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry FieldName
argumentName Value s
argumentValue
class Decode a where
decode :: ValidValue -> ResolverState a
instance DecodeKind (KIND a) a => Decode a where
decode :: ValidValue -> ResolverState a
decode = Proxy (KIND a) -> ValidValue -> ResolverState a
forall (kind :: DerivingKind) a.
DecodeKind kind a =>
Proxy kind -> ValidValue -> ResolverState a
decodeKind (Proxy (KIND a)
forall k (t :: k). Proxy t
Proxy @(KIND a))
class DecodeKind (kind :: DerivingKind) a where
decodeKind :: Proxy kind -> ValidValue -> ResolverState a
instance (DecodeScalar a, GQLType a) => DecodeKind SCALAR a where
decodeKind :: Proxy SCALAR -> ValidValue -> ResolverState a
decodeKind Proxy SCALAR
_ = TypeName
-> (ScalarValue -> Either Token a) -> ValidValue -> ResolverState a
forall (m :: * -> *) a.
(Applicative m, MonadError GQLError m) =>
TypeName -> (ScalarValue -> Either Token a) -> ValidValue -> m a
withScalar (TypeData -> TypeName
gqlTypeName (TypeData -> TypeName) -> TypeData -> TypeName
forall a b. (a -> b) -> a -> b
$ KindedProxy LEAF a -> TypeData
forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData (KindedProxy LEAF a
forall k k (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy LEAF a)) ScalarValue -> Either Token a
forall a. DecodeScalar a => ScalarValue -> Either Token a
decodeScalar
instance
( Generic a,
GQLType a,
DecodeRep (Rep a)
) =>
DecodeKind TYPE a
where
decodeKind :: Proxy TYPE -> ValidValue -> ResolverState a
decodeKind Proxy TYPE
_ = (Rep a Any -> a) -> ResolverState (Rep a Any) -> ResolverState a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (ResolverState (Rep a Any) -> ResolverState a)
-> (ValidValue -> ResolverState (Rep a Any))
-> ValidValue
-> ResolverState a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT Context ResolverState (Rep a Any)
-> Context -> ResolverState (Rep a Any)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Context
context) (ReaderT Context ResolverState (Rep a Any)
-> ResolverState (Rep a Any))
-> (ValidValue -> ReaderT Context ResolverState (Rep a Any))
-> ValidValue
-> ResolverState (Rep a Any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidValue -> ReaderT Context ResolverState (Rep a Any)
forall (f :: * -> *) a. DecodeRep f => ValidValue -> DecoderT (f a)
decodeRep
where
context :: Context
context =
Context :: Tag -> TypeName -> GQLTypeOptions -> Context
Context
{ options :: GQLTypeOptions
options = Proxy a -> GQLTypeOptions -> GQLTypeOptions
forall a (f :: * -> *).
GQLType a =>
f a -> GQLTypeOptions -> GQLTypeOptions
typeOptions (Proxy a
forall k (t :: k). Proxy t
Proxy @a) GQLTypeOptions
defaultTypeOptions,
contKind :: Tag
contKind = Tag
D_CONS,
typeName :: TypeName
typeName = TypeData -> TypeName
gqlTypeName (TypeData -> TypeName) -> TypeData -> TypeName
forall a b. (a -> b) -> a -> b
$ KindedProxy IN a -> TypeData
forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData (KindedProxy IN a
forall k k (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy IN a)
}
instance (Decode a, DecodeWrapperConstraint f a, DecodeWrapper f) => DecodeKind WRAPPER (f a) where
decodeKind :: Proxy WRAPPER -> ValidValue -> ResolverState (f a)
decodeKind Proxy WRAPPER
_ ValidValue
value =
ExceptT GQLError ResolverState (f a)
-> ResolverStateT () Identity (Either GQLError (f a))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ((ValidValue -> ResolverStateT () Identity a)
-> ValidValue -> ExceptT GQLError ResolverState (f a)
forall (f :: * -> *) (m :: * -> *) a.
(DecodeWrapper f, Monad m, DecodeWrapperConstraint f a) =>
(ValidValue -> m a) -> ValidValue -> ExceptT GQLError m (f a)
decodeWrapper ValidValue -> ResolverStateT () Identity a
forall a. Decode a => ValidValue -> ResolverState a
decode ValidValue
value)
ResolverStateT () Identity (Either GQLError (f a))
-> (Either GQLError (f a) -> ResolverState (f a))
-> ResolverState (f a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either GQLError (f a) -> ResolverState (f a)
forall (m :: * -> *) a.
MonadError GQLError m =>
Either GQLError a -> m a
handleEither
instance (Decode a, KnownSymbol name) => DecodeKind CUSTOM (Arg name a) where
decodeKind :: Proxy CUSTOM -> ValidValue -> ResolverState (Arg name a)
decodeKind Proxy CUSTOM
_ ValidValue
value = a -> Arg name a
forall (name :: Symbol) a. a -> Arg name a
Arg (a -> Arg name a)
-> ResolverStateT () Identity a -> ResolverState (Arg name a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object VALID -> ResolverStateT () Identity a)
-> ValidValue -> ResolverStateT () Identity a
forall (m :: * -> *) a.
MonadError GQLError m =>
(Object VALID -> m a) -> ValidValue -> m a
withInputObject Object VALID -> ResolverStateT () Identity a
fieldDecoder ValidValue
value
where
fieldDecoder :: Object VALID -> ResolverStateT () Identity a
fieldDecoder = (ValidValue -> ResolverStateT () Identity a)
-> FieldName -> Object VALID -> ResolverStateT () Identity a
forall (m :: * -> *) a.
(ValidValue -> m a) -> FieldName -> Object VALID -> m a
decodeFieldWith ValidValue -> ResolverStateT () Identity a
forall a. Decode a => ValidValue -> ResolverState a
decode FieldName
fieldName
fieldName :: FieldName
fieldName = Proxy name -> FieldName
forall (a :: Symbol) (f :: Symbol -> *).
KnownSymbol a =>
f a -> FieldName
symbolName (Proxy name
forall k (t :: k). Proxy t
Proxy @name)
instance (Ord k, Decode (k, v)) => DecodeKind CUSTOM (Map k v) where
decodeKind :: Proxy CUSTOM -> ValidValue -> ResolverState (Map k v)
decodeKind Proxy CUSTOM
_ ValidValue
v = [(k, v)] -> Map k v
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(k, v)] -> Map k v)
-> ResolverStateT () Identity [(k, v)] -> ResolverState (Map k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ValidValue -> ResolverStateT () Identity [(k, v)]
forall a. Decode a => ValidValue -> ResolverState a
decode ValidValue
v :: ResolverState [(k, v)])
decideUnion ::
( Functor m,
MonadError GQLError m
) =>
([TypeName], value -> m (f1 a)) ->
([TypeName], value -> m (f2 a)) ->
TypeName ->
value ->
m ((:+:) f1 f2 a)
decideUnion :: ([TypeName], value -> m (f1 a))
-> ([TypeName], value -> m (f2 a))
-> TypeName
-> value
-> m ((:+:) f1 f2 a)
decideUnion ([TypeName]
left, value -> m (f1 a)
f1) ([TypeName]
right, value -> m (f2 a)
f2) TypeName
name value
value
| TypeName
name TypeName -> [TypeName] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [TypeName]
left =
f1 a -> (:+:) f1 f2 a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f1 a -> (:+:) f1 f2 a) -> m (f1 a) -> m ((:+:) f1 f2 a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> value -> m (f1 a)
f1 value
value
| TypeName
name TypeName -> [TypeName] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [TypeName]
right =
f2 a -> (:+:) f1 f2 a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (f2 a -> (:+:) f1 f2 a) -> m (f2 a) -> m ((:+:) f1 f2 a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> value -> m (f2 a)
f2 value
value
| Bool
otherwise =
GQLError -> m ((:+:) f1 f2 a)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
(GQLError -> m ((:+:) f1 f2 a)) -> GQLError -> m ((:+:) f1 f2 a)
forall a b. (a -> b) -> a -> b
$ GQLError -> GQLError
internal
(GQLError -> GQLError) -> GQLError -> GQLError
forall a b. (a -> b) -> a -> b
$ GQLError
"Constructor \""
GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeName -> GQLError
forall a. Msg a => a -> GQLError
msg TypeName
name
GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
"\" could not find in Union"
traverseUnion ::
(DecodeRep f, DecodeRep g) =>
([TypeName], [TypeName]) ->
TypeName ->
Object VALID ->
ValidObject ->
DecoderT ((f :+: g) a)
traverseUnion :: ([TypeName], [TypeName])
-> TypeName
-> Object VALID
-> Object VALID
-> DecoderT ((:+:) f g a)
traverseUnion ([TypeName]
l1, [TypeName]
r1) TypeName
name Object VALID
unions Object VALID
object
| [TypeName
name] [TypeName] -> [TypeName] -> Bool
forall a. Eq a => a -> a -> Bool
== [TypeName]
l1 =
f a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f a -> (:+:) f g a)
-> ReaderT Context ResolverState (f a) -> DecoderT ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValidValue -> ReaderT Context ResolverState (f a)
forall (f :: * -> *) a. DecodeRep f => ValidValue -> DecoderT (f a)
decodeRep (Object VALID -> ValidValue
forall (stage :: Stage). Object stage -> Value stage
Object Object VALID
object)
| [TypeName
name] [TypeName] -> [TypeName] -> Bool
forall a. Eq a => a -> a -> Bool
== [TypeName]
r1 =
g a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g a -> (:+:) f g a)
-> ReaderT Context ResolverState (g a) -> DecoderT ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValidValue -> ReaderT Context ResolverState (g a)
forall (f :: * -> *) a. DecodeRep f => ValidValue -> DecoderT (f a)
decodeRep (Object VALID -> ValidValue
forall (stage :: Stage). Object stage -> Value stage
Object Object VALID
object)
| Bool
otherwise = ([TypeName], ValidValue -> ReaderT Context ResolverState (f a))
-> ([TypeName], ValidValue -> ReaderT Context ResolverState (g a))
-> TypeName
-> ValidValue
-> DecoderT ((:+:) f g a)
forall (m :: * -> *) value (f1 :: * -> *) a (f2 :: * -> *).
(Functor m, MonadError GQLError m) =>
([TypeName], value -> m (f1 a))
-> ([TypeName], value -> m (f2 a))
-> TypeName
-> value
-> m ((:+:) f1 f2 a)
decideUnion ([TypeName]
l1, ValidValue -> ReaderT Context ResolverState (f a)
forall (f :: * -> *) a. DecodeRep f => ValidValue -> DecoderT (f a)
decodeRep) ([TypeName]
r1, ValidValue -> ReaderT Context ResolverState (g a)
forall (f :: * -> *) a. DecodeRep f => ValidValue -> DecoderT (f a)
decodeRep) TypeName
name (Object VALID -> ValidValue
forall (stage :: Stage). Object stage -> Value stage
Object Object VALID
unions)
data Tag = D_CONS | D_UNION deriving (Tag -> Tag -> Bool
(Tag -> Tag -> Bool) -> (Tag -> Tag -> Bool) -> Eq Tag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tag -> Tag -> Bool
$c/= :: Tag -> Tag -> Bool
== :: Tag -> Tag -> Bool
$c== :: Tag -> Tag -> Bool
Eq, Eq Tag
Eq Tag
-> (Tag -> Tag -> Ordering)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Tag)
-> (Tag -> Tag -> Tag)
-> Ord Tag
Tag -> Tag -> Bool
Tag -> Tag -> Ordering
Tag -> Tag -> Tag
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Tag -> Tag -> Tag
$cmin :: Tag -> Tag -> Tag
max :: Tag -> Tag -> Tag
$cmax :: Tag -> Tag -> Tag
>= :: Tag -> Tag -> Bool
$c>= :: Tag -> Tag -> Bool
> :: Tag -> Tag -> Bool
$c> :: Tag -> Tag -> Bool
<= :: Tag -> Tag -> Bool
$c<= :: Tag -> Tag -> Bool
< :: Tag -> Tag -> Bool
$c< :: Tag -> Tag -> Bool
compare :: Tag -> Tag -> Ordering
$ccompare :: Tag -> Tag -> Ordering
$cp1Ord :: Eq Tag
Ord)
data Context = Context
{ Context -> Tag
contKind :: Tag,
Context -> TypeName
typeName :: TypeName,
Context -> GQLTypeOptions
options :: GQLTypeOptions
}
data Info = Info
{ Info -> Tag
kind :: Tag,
Info -> [TypeName]
tagName :: [TypeName]
}
instance Semigroup Info where
Info Tag
D_UNION [TypeName]
t1 <> :: Info -> Info -> Info
<> Info Tag
_ [TypeName]
t2 = Tag -> [TypeName] -> Info
Info Tag
D_UNION ([TypeName]
t1 [TypeName] -> [TypeName] -> [TypeName]
forall a. Semigroup a => a -> a -> a
<> [TypeName]
t2)
Info Tag
_ [TypeName]
t1 <> Info Tag
D_UNION [TypeName]
t2 = Tag -> [TypeName] -> Info
Info Tag
D_UNION ([TypeName]
t1 [TypeName] -> [TypeName] -> [TypeName]
forall a. Semigroup a => a -> a -> a
<> [TypeName]
t2)
Info Tag
D_CONS [TypeName]
t1 <> Info Tag
D_CONS [TypeName]
t2 = Tag -> [TypeName] -> Info
Info Tag
D_CONS ([TypeName]
t1 [TypeName] -> [TypeName] -> [TypeName]
forall a. Semigroup a => a -> a -> a
<> [TypeName]
t2)
type DecoderT = ReaderT Context ResolverState
withKind :: Tag -> DecoderT a -> DecoderT a
withKind :: Tag -> DecoderT a -> DecoderT a
withKind Tag
contKind = (Context -> Context) -> DecoderT a -> DecoderT a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Context
ctx -> Context
ctx {Tag
contKind :: Tag
contKind :: Tag
contKind})
getUnionInfos ::
forall f a b.
(DecodeRep a, DecodeRep b) =>
f (a :+: b) ->
DecoderT (Info, Info)
getUnionInfos :: f (a :+: b) -> DecoderT (Info, Info)
getUnionInfos f (a :+: b)
_ =
( \Context
context ->
( Proxy a -> Context -> Info
forall (f :: * -> *). DecodeRep f => Proxy f -> Context -> Info
tags (Proxy a
forall k (t :: k). Proxy t
Proxy @a) Context
context,
Proxy b -> Context -> Info
forall (f :: * -> *). DecodeRep f => Proxy f -> Context -> Info
tags (Proxy b
forall k (t :: k). Proxy t
Proxy @b) Context
context
)
)
(Context -> (Info, Info))
-> ReaderT Context ResolverState Context -> DecoderT (Info, Info)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Context ResolverState Context
forall r (m :: * -> *). MonadReader r m => m r
ask
class DecodeRep (f :: Type -> Type) where
tags :: Proxy f -> Context -> Info
decodeRep :: ValidValue -> DecoderT (f a)
instance (Datatype d, DecodeRep f) => DecodeRep (M1 D d f) where
tags :: Proxy (M1 D d f) -> Context -> Info
tags Proxy (M1 D d f)
_ = Proxy f -> Context -> Info
forall (f :: * -> *). DecodeRep f => Proxy f -> Context -> Info
tags (Proxy f
forall k (t :: k). Proxy t
Proxy @f)
decodeRep :: ValidValue -> DecoderT (M1 D d f a)
decodeRep ValidValue
value = f a -> M1 D d f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 D d f a)
-> ReaderT Context ResolverState (f a) -> DecoderT (M1 D d f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValidValue -> ReaderT Context ResolverState (f a)
forall (f :: * -> *) a. DecodeRep f => ValidValue -> DecoderT (f a)
decodeRep ValidValue
value
instance (DecodeRep a, DecodeRep b) => DecodeRep (a :+: b) where
tags :: Proxy (a :+: b) -> Context -> Info
tags Proxy (a :+: b)
_ = Proxy a -> Context -> Info
forall (f :: * -> *). DecodeRep f => Proxy f -> Context -> Info
tags (Proxy a
forall k (t :: k). Proxy t
Proxy @a) (Context -> Info) -> (Context -> Info) -> Context -> Info
forall a. Semigroup a => a -> a -> a
<> Proxy b -> Context -> Info
forall (f :: * -> *). DecodeRep f => Proxy f -> Context -> Info
tags (Proxy b
forall k (t :: k). Proxy t
Proxy @b)
decodeRep :: ValidValue -> DecoderT ((:+:) a b a)
decodeRep (Object Object VALID
obj) =
do
(Info
left, Info
right) <- Proxy (a :+: b) -> DecoderT (Info, Info)
forall (f :: (* -> *) -> *) (a :: * -> *) (b :: * -> *).
(DecodeRep a, DecodeRep b) =>
f (a :+: b) -> DecoderT (Info, Info)
getUnionInfos (Proxy (a :+: b)
forall k (t :: k). Proxy t
Proxy @(a :+: b))
Tag -> DecoderT ((:+:) a b a) -> DecoderT ((:+:) a b a)
forall a. Tag -> DecoderT a -> DecoderT a
withKind (Info -> Tag
kind (Info
left Info -> Info -> Info
forall a. Semigroup a => a -> a -> a
<> Info
right)) (DecoderT ((:+:) a b a) -> DecoderT ((:+:) a b a))
-> DecoderT ((:+:) a b a) -> DecoderT ((:+:) a b a)
forall a b. (a -> b) -> a -> b
$
(TypeName
-> Object VALID -> Object VALID -> DecoderT ((:+:) a b a))
-> Object VALID -> DecoderT ((:+:) a b a)
forall (m :: * -> *) a.
(MonadError GQLError m, Monad m) =>
(TypeName -> Object VALID -> Object VALID -> m a)
-> Object VALID -> m a
withInputUnion
(([TypeName], [TypeName])
-> TypeName
-> Object VALID
-> Object VALID
-> DecoderT ((:+:) a b a)
forall (f :: * -> *) (g :: * -> *) a.
(DecodeRep f, DecodeRep g) =>
([TypeName], [TypeName])
-> TypeName
-> Object VALID
-> Object VALID
-> DecoderT ((:+:) f g a)
traverseUnion (Info -> [TypeName]
tagName Info
left, Info -> [TypeName]
tagName Info
right))
Object VALID
obj
decodeRep (Enum TypeName
name) = do
(Info
left, Info
right) <- Proxy (a :+: b) -> DecoderT (Info, Info)
forall (f :: (* -> *) -> *) (a :: * -> *) (b :: * -> *).
(DecodeRep a, DecodeRep b) =>
f (a :+: b) -> DecoderT (Info, Info)
getUnionInfos (Proxy (a :+: b)
forall k (t :: k). Proxy t
Proxy @(a :+: b))
([TypeName], ValidValue -> ReaderT Context ResolverState (a a))
-> ([TypeName], ValidValue -> ReaderT Context ResolverState (b a))
-> TypeName
-> ValidValue
-> DecoderT ((:+:) a b a)
forall (m :: * -> *) value (f1 :: * -> *) a (f2 :: * -> *).
(Functor m, MonadError GQLError m) =>
([TypeName], value -> m (f1 a))
-> ([TypeName], value -> m (f2 a))
-> TypeName
-> value
-> m ((:+:) f1 f2 a)
decideUnion
(Info -> [TypeName]
tagName Info
left, ValidValue -> ReaderT Context ResolverState (a a)
forall (f :: * -> *) a. DecodeRep f => ValidValue -> DecoderT (f a)
decodeRep)
(Info -> [TypeName]
tagName Info
right, ValidValue -> ReaderT Context ResolverState (b a)
forall (f :: * -> *) a. DecodeRep f => ValidValue -> DecoderT (f a)
decodeRep)
TypeName
name
(TypeName -> ValidValue
forall (stage :: Stage). TypeName -> Value stage
Enum TypeName
name)
decodeRep ValidValue
_ = GQLError -> DecoderT ((:+:) a b a)
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 a) => DecodeRep (M1 C c a) where
decodeRep :: ValidValue -> DecoderT (M1 C c a a)
decodeRep = (a a -> M1 C c a a)
-> ReaderT Context ResolverState (a a) -> DecoderT (M1 C c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a a -> M1 C c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (ReaderT Context ResolverState (a a) -> DecoderT (M1 C c a a))
-> (ValidValue -> ReaderT Context ResolverState (a a))
-> ValidValue
-> DecoderT (M1 C c a a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ValidValue -> ReaderT Context ResolverState (a a)
forall (f :: * -> *) a.
DecodeFields f =>
Int -> ValidValue -> DecoderT (f a)
decodeFields Int
0
tags :: Proxy (M1 C c a) -> Context -> Info
tags Proxy (M1 C c a)
_ Context {TypeName
typeName :: TypeName
typeName :: Context -> TypeName
typeName, GQLTypeOptions
options :: GQLTypeOptions
options :: Context -> GQLTypeOptions
options} = Maybe TypeName -> Info
getTag (Proxy a -> Maybe TypeName
forall (f :: * -> *). DecodeFields f => Proxy f -> Maybe TypeName
refType (Proxy a
forall k (t :: k). Proxy t
Proxy @a))
where
getTag :: Maybe TypeName -> Info
getTag (Just TypeName
memberRef)
| TypeName -> Bool
isUnionRef TypeName
memberRef = Info :: Tag -> [TypeName] -> Info
Info {kind :: Tag
kind = Tag
D_UNION, tagName :: [TypeName]
tagName = [TypeName
memberRef]}
| Bool
otherwise = Info :: Tag -> [TypeName] -> Info
Info {kind :: Tag
kind = Tag
D_CONS, tagName :: [TypeName]
tagName = [TypeName
consName]}
getTag Maybe TypeName
Nothing = Info :: Tag -> [TypeName] -> Info
Info {kind :: Tag
kind = Tag
D_CONS, tagName :: [TypeName]
tagName = [TypeName
consName]}
consName :: TypeName
consName = GQLTypeOptions -> Proxy c -> TypeName
forall (f :: Meta -> *) (c :: Meta).
Constructor c =>
GQLTypeOptions -> f c -> TypeName
conNameProxy GQLTypeOptions
options (Proxy c
forall k (t :: k). Proxy t
Proxy @c)
isUnionRef :: TypeName -> Bool
isUnionRef TypeName
x = TypeName
typeName TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> TypeName
x TypeName -> TypeName -> Bool
forall a. Eq a => a -> a -> Bool
== TypeName
consName
class DecodeFields (f :: Type -> Type) where
refType :: Proxy f -> Maybe TypeName
countFields :: Proxy f -> Int
decodeFields :: Int -> ValidValue -> DecoderT (f a)
instance (DecodeFields f, DecodeFields g) => DecodeFields (f :*: g) where
refType :: Proxy (f :*: g) -> Maybe TypeName
refType Proxy (f :*: g)
_ = Maybe TypeName
forall a. Maybe a
Nothing
countFields :: Proxy (f :*: g) -> Int
countFields Proxy (f :*: g)
_ = Proxy f -> Int
forall (f :: * -> *). DecodeFields f => Proxy f -> Int
countFields (Proxy f
forall k (t :: k). Proxy t
Proxy @f) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Proxy g -> Int
forall (f :: * -> *). DecodeFields f => Proxy f -> Int
countFields (Proxy g
forall k (t :: k). Proxy t
Proxy @g)
decodeFields :: Int -> ValidValue -> DecoderT ((:*:) f g a)
decodeFields Int
index ValidValue
gql =
f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (f a -> g a -> (:*:) f g a)
-> ReaderT Context ResolverState (f a)
-> ReaderT Context ResolverState (g a -> (:*:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> ValidValue -> ReaderT Context ResolverState (f a)
forall (f :: * -> *) a.
DecodeFields f =>
Int -> ValidValue -> DecoderT (f a)
decodeFields Int
index ValidValue
gql
ReaderT Context ResolverState (g a -> (:*:) f g a)
-> ReaderT Context ResolverState (g a) -> DecoderT ((:*:) f g a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> ValidValue -> ReaderT Context ResolverState (g a)
forall (f :: * -> *) a.
DecodeFields f =>
Int -> ValidValue -> DecoderT (f a)
decodeFields (Int
index Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Proxy g -> Int
forall (f :: * -> *). DecodeFields f => Proxy f -> Int
countFields (Proxy g
forall k (t :: k). Proxy t
Proxy @g)) ValidValue
gql
instance (Selector s, GQLType a, Decode a) => DecodeFields (M1 S s (K1 i a)) where
countFields :: Proxy (M1 S s (K1 i a)) -> Int
countFields Proxy (M1 S s (K1 i a))
_ = Int
1
refType :: Proxy (M1 S s (K1 i a)) -> Maybe TypeName
refType Proxy (M1 S s (K1 i a))
_ = TypeName -> Maybe TypeName
forall a. a -> Maybe a
Just (TypeName -> Maybe TypeName) -> TypeName -> Maybe TypeName
forall a b. (a -> b) -> a -> b
$ TypeData -> TypeName
gqlTypeName (TypeData -> TypeName) -> TypeData -> TypeName
forall a b. (a -> b) -> a -> b
$ KindedProxy IN a -> TypeData
forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData (KindedProxy IN a
forall k k (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy IN a)
decodeFields :: Int -> ValidValue -> DecoderT (M1 S s (K1 i a) a)
decodeFields Int
index ValidValue
value = K1 i a a -> M1 S s (K1 i a) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 i a a -> M1 S s (K1 i a) a)
-> (a -> K1 i a a) -> a -> M1 S s (K1 i a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> M1 S s (K1 i a) a)
-> ReaderT Context ResolverState a -> DecoderT (M1 S s (K1 i a) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
Context {GQLTypeOptions
options :: GQLTypeOptions
options :: Context -> GQLTypeOptions
options, Tag
contKind :: Tag
contKind :: Context -> Tag
contKind} <- ReaderT Context ResolverState Context
forall r (m :: * -> *). MonadReader r m => m r
ask
case Tag
contKind of
Tag
D_UNION -> ResolverStateT () Identity a -> ReaderT Context ResolverState a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ValidValue -> ResolverStateT () Identity a
forall a. Decode a => ValidValue -> ResolverState a
decode ValidValue
value)
Tag
D_CONS ->
let fieldName :: FieldName
fieldName = FieldName -> Int -> FieldName
getFieldName (GQLTypeOptions -> Proxy s -> FieldName
forall (f :: Meta -> *) (s :: Meta).
Selector s =>
GQLTypeOptions -> f s -> FieldName
selNameProxy GQLTypeOptions
options (Proxy s
forall k (t :: k). Proxy t
Proxy @s)) Int
index
fieldDecoder :: Object VALID -> ReaderT Context ResolverState a
fieldDecoder = (ValidValue -> ReaderT Context ResolverState a)
-> FieldName -> Object VALID -> ReaderT Context ResolverState a
forall (m :: * -> *) a.
(ValidValue -> m a) -> FieldName -> Object VALID -> m a
decodeFieldWith (ResolverStateT () Identity a -> ReaderT Context ResolverState a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ResolverStateT () Identity a -> ReaderT Context ResolverState a)
-> (ValidValue -> ResolverStateT () Identity a)
-> ValidValue
-> ReaderT Context ResolverState a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidValue -> ResolverStateT () Identity a
forall a. Decode a => ValidValue -> ResolverState a
decode) FieldName
fieldName
in (Object VALID -> ReaderT Context ResolverState a)
-> ValidValue -> ReaderT Context ResolverState a
forall (m :: * -> *) a.
MonadError GQLError m =>
(Object VALID -> m a) -> ValidValue -> m a
withInputObject Object VALID -> ReaderT Context ResolverState a
fieldDecoder ValidValue
value
getFieldName :: FieldName -> Int -> FieldName
getFieldName :: FieldName -> Int -> FieldName
getFieldName FieldName
"" Int
index = FieldName
"_" FieldName -> FieldName -> FieldName
forall a. Semigroup a => a -> a -> a
<> Int -> FieldName
forall b a. (Show a, IsString b) => a -> b
show Int
index
getFieldName FieldName
label Int
_ = FieldName
label
instance DecodeFields U1 where
countFields :: Proxy U1 -> Int
countFields Proxy U1
_ = Int
0
refType :: Proxy U1 -> Maybe TypeName
refType Proxy U1
_ = Maybe TypeName
forall a. Maybe a
Nothing
decodeFields :: Int -> ValidValue -> DecoderT (U1 a)
decodeFields Int
_ ValidValue
_ = U1 a -> DecoderT (U1 a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1