{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.App.Internal.Resolving.ResolveValue
( resolveRef,
resolveObject,
)
where
import Control.Monad.Except (MonadError (throwError))
import qualified Data.HashMap.Lazy as HM
import Data.Morpheus.App.Internal.Resolving.ResolverState
( ResolverContext (..),
askFieldTypeName,
updateCurrentType,
)
import Data.Morpheus.App.Internal.Resolving.Types
( NamedResolver (..),
NamedResolverRef (..),
NamedResolverResult (..),
ObjectTypeResolver (..),
ResolverMap,
ResolverValue (..),
mkEnum,
mkUnion,
)
import Data.Morpheus.Error (subfieldsNotSelected)
import Data.Morpheus.Internal.Utils
( KeyOf (keyOf),
empty,
selectOr,
traverseCollection,
(<:>),
)
import Data.Morpheus.Types.Internal.AST
( GQLError,
Msg (msg),
ObjectEntry (ObjectEntry),
ScalarValue (..),
Selection (..),
SelectionContent (..),
SelectionSet,
TypeDefinition (..),
TypeName,
UnionTag (unionTagSelection),
VALID,
ValidValue,
Value (..),
internal,
unitFieldName,
unitTypeName,
unpackName,
)
import Relude hiding (empty)
resolveSelection ::
( Monad m,
MonadReader ResolverContext m,
MonadError GQLError m
) =>
ResolverMap m ->
ResolverValue m ->
SelectionContent VALID ->
m ValidValue
resolveSelection :: forall (m :: * -> *).
(Monad m, MonadReader ResolverContext m, MonadError GQLError m) =>
ResolverMap m
-> ResolverValue m -> SelectionContent VALID -> m ValidValue
resolveSelection ResolverMap m
rmap (ResLazy m (ResolverValue m)
x) SelectionContent VALID
selection =
m (ResolverValue m)
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (m :: * -> *).
(Monad m, MonadReader ResolverContext m, MonadError GQLError m) =>
ResolverMap m
-> ResolverValue m -> SelectionContent VALID -> m ValidValue
resolveSelection ResolverMap m
rmap) SelectionContent VALID
selection
resolveSelection ResolverMap m
rmap (ResList [ResolverValue m]
xs) SelectionContent VALID
selection =
forall (stage :: Stage). [Value stage] -> Value stage
List forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (m :: * -> *).
(Monad m, MonadReader ResolverContext m, MonadError GQLError m) =>
ResolverMap m
-> ResolverValue m -> SelectionContent VALID -> m ValidValue
resolveSelection ResolverMap m
rmap) SelectionContent VALID
selection) [ResolverValue m]
xs
resolveSelection ResolverMap m
rmap (ResObject Maybe TypeName
tyName ObjectTypeResolver m
obj) SelectionContent VALID
sel = forall (m :: * -> *) value.
(MonadError GQLError m, MonadReader ResolverContext m) =>
Maybe TypeName
-> (Maybe (SelectionSet VALID) -> m value)
-> SelectionContent VALID
-> m value
withObject Maybe TypeName
tyName (forall (m :: * -> *).
(MonadReader ResolverContext m, MonadError GQLError m) =>
ResolverMap m
-> ObjectTypeResolver m
-> Maybe (SelectionSet VALID)
-> m ValidValue
resolveObject ResolverMap m
rmap ObjectTypeResolver m
obj) SelectionContent VALID
sel
resolveSelection ResolverMap m
_ (ResEnum TypeName
name) SelectionContent VALID
SelectionField = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (stage :: Stage). ScalarValue -> Value stage
Scalar forall a b. (a -> b) -> a -> b
$ Text -> ScalarValue
String forall a b. (a -> b) -> a -> b
$ forall a (t :: NAME). NamePacking a => Name t -> a
unpackName TypeName
name
resolveSelection ResolverMap m
rmap (ResEnum TypeName
name) unionSel :: SelectionContent VALID
unionSel@UnionSelection {} =
forall (m :: * -> *).
(Monad m, MonadReader ResolverContext m, MonadError GQLError m) =>
ResolverMap m
-> ResolverValue m -> SelectionContent VALID -> m ValidValue
resolveSelection ResolverMap m
rmap (forall (m :: * -> *).
Monad m =>
TypeName -> [ResolverEntry m] -> ResolverValue m
mkUnion TypeName
name [(FieldName
unitFieldName, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). TypeName -> ResolverValue m
mkEnum TypeName
unitTypeName)]) SelectionContent VALID
unionSel
resolveSelection ResolverMap m
_ ResEnum {} SelectionContent VALID
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"wrong selection on enum value")
resolveSelection ResolverMap m
_ ResolverValue m
ResNull SelectionContent VALID
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (stage :: Stage). Value stage
Null
resolveSelection ResolverMap m
_ (ResScalar ScalarValue
x) SelectionContent VALID
SelectionField = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (stage :: Stage). ScalarValue -> Value stage
Scalar ScalarValue
x
resolveSelection ResolverMap m
_ ResScalar {} SelectionContent VALID
_ =
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"scalar Resolver should only receive SelectionField")
resolveSelection ResolverMap m
rmap (ResRef m NamedResolverRef
ref) SelectionContent VALID
sel = m NamedResolverRef
ref forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (m :: * -> *).
(MonadError GQLError m, MonadReader ResolverContext m) =>
ResolverMap m
-> NamedResolverRef -> SelectionContent VALID -> m ValidValue
resolveRef ResolverMap m
rmap) SelectionContent VALID
sel
withObject ::
( MonadError GQLError m,
MonadReader ResolverContext m
) =>
Maybe TypeName ->
(Maybe (SelectionSet VALID) -> m value) ->
SelectionContent VALID ->
m value
withObject :: forall (m :: * -> *) value.
(MonadError GQLError m, MonadReader ResolverContext m) =>
Maybe TypeName
-> (Maybe (SelectionSet VALID) -> m value)
-> SelectionContent VALID
-> m value
withObject Maybe TypeName
__typename Maybe (SelectionSet VALID) -> m value
f = forall (m :: * -> *) a.
(MonadReader ResolverContext m, MonadError GQLError m) =>
Maybe TypeName -> m a -> m a
updateCurrentType Maybe TypeName
__typename forall b c a. (b -> c) -> (a -> b) -> a -> c
. SelectionContent VALID -> m value
checkContent
where
checkContent :: SelectionContent VALID -> m value
checkContent (SelectionSet SelectionSet VALID
selection) = Maybe (SelectionSet VALID) -> m value
f (forall a. a -> Maybe a
Just SelectionSet VALID
selection)
checkContent (UnionSelection Maybe (SelectionSet VALID)
interface UnionSelection VALID
unionSel) = do
TypeName
typename <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolverContext -> TypeDefinition ANY VALID
currentType)
Maybe (MergeMap 'False FieldName (Selection VALID))
selection <- forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr (forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (SelectionSet VALID)
interface) (forall {f :: * -> *}.
MonadError GQLError f =>
Maybe (MergeMap 'False FieldName (Selection VALID))
-> UnionTag
-> f (Maybe (MergeMap 'False FieldName (Selection VALID)))
fx Maybe (SelectionSet VALID)
interface) TypeName
typename UnionSelection VALID
unionSel
Maybe (SelectionSet VALID) -> m value
f Maybe (MergeMap 'False FieldName (Selection VALID))
selection
where
fx :: Maybe (MergeMap 'False FieldName (Selection VALID))
-> UnionTag
-> f (Maybe (MergeMap 'False FieldName (Selection VALID)))
fx (Just MergeMap 'False FieldName (Selection VALID)
x) UnionTag
y = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MergeMap 'False FieldName (Selection VALID)
x forall (m :: * -> *) a.
(Merge (HistoryT m) a, Monad m) =>
a -> a -> m a
<:> UnionTag -> SelectionSet VALID
unionTagSelection UnionTag
y)
fx Maybe (MergeMap 'False FieldName (Selection VALID))
Nothing UnionTag
y = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ UnionTag -> SelectionSet VALID
unionTagSelection UnionTag
y
checkContent SelectionContent VALID
_ = forall (m :: * -> *) value.
(MonadError GQLError m, MonadReader ResolverContext m) =>
m value
noEmptySelection
noEmptySelection :: (MonadError GQLError m, MonadReader ResolverContext m) => m value
noEmptySelection :: forall (m :: * -> *) value.
(MonadError GQLError m, MonadReader ResolverContext m) =>
m value
noEmptySelection = do
Selection VALID
sel <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ResolverContext -> Selection VALID
currentSelection
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ FieldName -> TypeName -> Position -> GQLError
subfieldsNotSelected (forall (s :: Stage). Selection s -> FieldName
selectionName Selection VALID
sel) TypeName
"" (forall (s :: Stage). Selection s -> Position
selectionPosition Selection VALID
sel)
resolveRef ::
( MonadError GQLError m,
MonadReader ResolverContext m
) =>
ResolverMap m ->
NamedResolverRef ->
SelectionContent VALID ->
m ValidValue
resolveRef :: forall (m :: * -> *).
(MonadError GQLError m, MonadReader ResolverContext m) =>
ResolverMap m
-> NamedResolverRef -> SelectionContent VALID -> m ValidValue
resolveRef ResolverMap m
rmap NamedResolverRef
ref SelectionContent VALID
selection = do
NamedResolverResult m
namedResolver <- forall (m :: * -> *).
MonadError GQLError m =>
NamedResolverRef -> ResolverMap m -> m (NamedResolverResult m)
getNamedResolverBy NamedResolverRef
ref ResolverMap m
rmap
case NamedResolverResult m
namedResolver of
NamedObjectResolver ObjectTypeResolver m
res -> forall (m :: * -> *) value.
(MonadError GQLError m, MonadReader ResolverContext m) =>
Maybe TypeName
-> (Maybe (SelectionSet VALID) -> m value)
-> SelectionContent VALID
-> m value
withObject (forall a. a -> Maybe a
Just (NamedResolverRef -> TypeName
resolverTypeName NamedResolverRef
ref)) (forall (m :: * -> *).
(MonadReader ResolverContext m, MonadError GQLError m) =>
ResolverMap m
-> ObjectTypeResolver m
-> Maybe (SelectionSet VALID)
-> m ValidValue
resolveObject ResolverMap m
rmap ObjectTypeResolver m
res) SelectionContent VALID
selection
NamedUnionResolver NamedResolverRef
unionRef -> forall (m :: * -> *).
(Monad m, MonadReader ResolverContext m, MonadError GQLError m) =>
ResolverMap m
-> ResolverValue m -> SelectionContent VALID -> m ValidValue
resolveSelection ResolverMap m
rmap (forall (m :: * -> *). m NamedResolverRef -> ResolverValue m
ResRef forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure NamedResolverRef
unionRef) SelectionContent VALID
selection
NamedEnumResolver TypeName
value -> forall (m :: * -> *).
(Monad m, MonadReader ResolverContext m, MonadError GQLError m) =>
ResolverMap m
-> ResolverValue m -> SelectionContent VALID -> m ValidValue
resolveSelection ResolverMap m
rmap (forall (m :: * -> *). TypeName -> ResolverValue m
ResEnum TypeName
value) SelectionContent VALID
selection
getNamedResolverBy ::
(MonadError GQLError m) =>
NamedResolverRef ->
ResolverMap m ->
m (NamedResolverResult m)
getNamedResolverBy :: forall (m :: * -> *).
MonadError GQLError m =>
NamedResolverRef -> ResolverMap m -> m (NamedResolverResult m)
getNamedResolverBy NamedResolverRef
ref = forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr m (NamedResolverResult m)
cantFoundError ((NamedResolverRef -> ValidValue
resolverArgument NamedResolverRef
ref forall a b. a -> (a -> b) -> b
&) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
NamedResolver m -> ValidValue -> m (NamedResolverResult m)
resolver) (NamedResolverRef -> TypeName
resolverTypeName NamedResolverRef
ref)
where
cantFoundError :: m (NamedResolverResult m)
cantFoundError = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError
"Resolver Type " forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg (NamedResolverRef -> TypeName
resolverTypeName NamedResolverRef
ref) forall a. Semigroup a => a -> a -> a
<> GQLError
"can't found")
resolveObject ::
( MonadReader ResolverContext m,
MonadError GQLError m
) =>
ResolverMap m ->
ObjectTypeResolver m ->
Maybe (SelectionSet VALID) ->
m ValidValue
resolveObject :: forall (m :: * -> *).
(MonadReader ResolverContext m, MonadError GQLError m) =>
ResolverMap m
-> ObjectTypeResolver m
-> Maybe (SelectionSet VALID)
-> m ValidValue
resolveObject ResolverMap m
rmap ObjectTypeResolver m
drv = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (stage :: Stage). Object stage -> Value stage
Object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall coll. Empty coll => coll
empty) (forall (m :: * -> *) k b (map :: * -> * -> *) (t :: * -> *) a.
(Monad m, Failure GQLError m, KeyOf k b, FromList m map k b,
Foldable t) =>
(a -> m b) -> t a -> m (map k b)
traverseCollection Selection VALID -> m (ObjectEntry VALID)
resolver)
where
resolver :: Selection VALID -> m (ObjectEntry VALID)
resolver Selection VALID
currentSelection = do
Maybe TypeName
t <- forall (m :: * -> *).
MonadReader ResolverContext m =>
FieldName -> m (Maybe TypeName)
askFieldTypeName (forall (s :: Stage). Selection s -> FieldName
selectionName Selection VALID
currentSelection)
forall (m :: * -> *) a.
(MonadReader ResolverContext m, MonadError GQLError m) =>
Maybe TypeName -> m a -> m a
updateCurrentType Maybe TypeName
t forall a b. (a -> b) -> a -> b
$
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ResolverContext
ctx -> ResolverContext
ctx {Selection VALID
currentSelection :: Selection VALID
currentSelection :: Selection VALID
currentSelection}) forall a b. (a -> b) -> a -> b
$
forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry (forall k a. KeyOf k a => a -> k
keyOf Selection VALID
currentSelection)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(Monad m, MonadReader ResolverContext m, MonadError GQLError m) =>
ResolverMap m
-> Selection VALID -> ObjectTypeResolver m -> m ValidValue
runFieldResolver ResolverMap m
rmap Selection VALID
currentSelection ObjectTypeResolver m
drv
runFieldResolver ::
( Monad m,
MonadReader ResolverContext m,
MonadError GQLError m
) =>
ResolverMap m ->
Selection VALID ->
ObjectTypeResolver m ->
m ValidValue
runFieldResolver :: forall (m :: * -> *).
(Monad m, MonadReader ResolverContext m, MonadError GQLError m) =>
ResolverMap m
-> Selection VALID -> ObjectTypeResolver m -> m ValidValue
runFieldResolver ResolverMap m
rmap Selection {FieldName
selectionName :: FieldName
selectionName :: forall (s :: Stage). Selection s -> FieldName
selectionName, SelectionContent VALID
selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s
selectionContent :: SelectionContent VALID
selectionContent}
| FieldName
selectionName forall a. Eq a => a -> a -> Bool
== FieldName
"__typename" =
forall a b. a -> b -> a
const (forall (stage :: Stage). ScalarValue -> Value stage
Scalar forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ScalarValue
String forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (t :: NAME). NamePacking a => Name t -> a
unpackName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolverContext -> TypeDefinition ANY VALID
currentType))
| Bool
otherwise =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (stage :: Stage). Value stage
Null) (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ResolverValue m
x -> forall (m :: * -> *).
(Monad m, MonadReader ResolverContext m, MonadError GQLError m) =>
ResolverMap m
-> ResolverValue m -> SelectionContent VALID -> m ValidValue
resolveSelection ResolverMap m
rmap ResolverValue m
x SelectionContent VALID
selectionContent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup FieldName
selectionName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
ObjectTypeResolver m -> HashMap FieldName (m (ResolverValue m))
objectFields