From 705e506c13b6c0f67ddf0195fa0d3256e7e4f9c3 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Mon, 29 Jun 2020 13:14:23 +0200 Subject: Combine Resolver and ActionT in ResolverT --- src/Language/GraphQL/Execute/Execution.hs | 10 +++---- src/Language/GraphQL/Trans.hs | 47 ++++++++++++++++++------------- src/Language/GraphQL/Type/Out.hs | 17 +++-------- src/Language/GraphQL/Type/Schema.hs | 6 ++-- 4 files changed, 38 insertions(+), 42 deletions(-) (limited to 'src/Language') diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs index 0c10419..0291bf8 100644 --- a/src/Language/GraphQL/Execute/Execution.hs +++ b/src/Language/GraphQL/Execute/Execution.hs @@ -33,12 +33,12 @@ import Prelude hiding (null) resolveFieldValue :: Monad m => Type.Value -> Type.Subs - -> ActionT m a + -> ResolverT m a -> m (Either Text a) resolveFieldValue result args = flip runReaderT (Context {arguments = Arguments args, values = result}) . runExceptT - . runActionT + . runResolverT collectFields :: Monad m => Out.ObjectType m @@ -99,12 +99,12 @@ instanceOf objectType (AbstractUnionType unionType) = go unionMemberType acc = acc || objectType == unionMemberType executeField :: (Monad m, Serialize a) - => Out.Resolver m + => Out.Field m -> Type.Value -> NonEmpty (Transform.Field m) -> CollectErrsT m a -executeField (Out.Resolver fieldDefinition resolver) prev fields = do - let Out.Field _ fieldType argumentDefinitions = fieldDefinition +executeField fieldDefinition prev fields = do + let Out.Field _ fieldType argumentDefinitions resolver = fieldDefinition let (Transform.Field _ _ arguments' _ :| []) = fields case coerceArgumentValues argumentDefinitions arguments' of Nothing -> errmsg "Argument coercing failed." diff --git a/src/Language/GraphQL/Trans.hs b/src/Language/GraphQL/Trans.hs index fa7718a..2ec13be 100644 --- a/src/Language/GraphQL/Trans.hs +++ b/src/Language/GraphQL/Trans.hs @@ -1,7 +1,7 @@ -- | Monad transformer stack used by the @GraphQL@ resolvers. module Language.GraphQL.Trans ( argument - , ActionT(..) + , ResolverT(..) , Context(..) ) where @@ -26,42 +26,49 @@ data Context = Context } -- | Monad transformer stack used by the resolvers to provide error handling --- and resolution context (resolver arguments). -newtype ActionT m a = ActionT - { runActionT :: ExceptT Text (ReaderT Context m) a +-- and resolution context (resolver arguments). +-- +-- Resolves a 'Field' into a 'Value' with error information (if an error has +-- occurred). @m@ is an arbitrary monad, usually 'IO'. +-- +-- Resolving a field can result in a leaf value or an object, which is +-- represented as a list of nested resolvers, used to resolve the fields of that +-- object. +newtype ResolverT m a = ResolverT + { runResolverT :: ExceptT Text (ReaderT Context m) a } -instance Functor m => Functor (ActionT m) where - fmap f = ActionT . fmap f . runActionT +instance Functor m => Functor (ResolverT m) where + fmap f = ResolverT . fmap f . runResolverT -instance Monad m => Applicative (ActionT m) where - pure = ActionT . pure - (ActionT f) <*> (ActionT x) = ActionT $ f <*> x +instance Monad m => Applicative (ResolverT m) where + pure = ResolverT . pure + (ResolverT f) <*> (ResolverT x) = ResolverT $ f <*> x -instance Monad m => Monad (ActionT m) where +instance Monad m => Monad (ResolverT m) where return = pure - (ActionT action) >>= f = ActionT $ action >>= runActionT . f + (ResolverT action) >>= f = ResolverT $ action >>= runResolverT . f -instance MonadTrans ActionT where - lift = ActionT . lift . lift +instance MonadTrans ResolverT where + lift = ResolverT . lift . lift -instance MonadIO m => MonadIO (ActionT m) where +instance MonadIO m => MonadIO (ResolverT m) where liftIO = lift . liftIO -instance Monad m => Alternative (ActionT m) where - empty = ActionT empty - (ActionT x) <|> (ActionT y) = ActionT $ x <|> y +instance Monad m => Alternative (ResolverT m) where + empty = ResolverT empty + (ResolverT x) <|> (ResolverT y) = ResolverT $ x <|> y -instance Monad m => MonadPlus (ActionT m) where +instance Monad m => MonadPlus (ResolverT m) where mzero = empty mplus = (<|>) -- | Retrieves an argument by its name. If the argument with this name couldn't -- be found, returns 'Null' (i.e. the argument is assumed to -- be optional then). -argument :: Monad m => Name -> ActionT m Value +argument :: Monad m => Name -> ResolverT m Value argument argumentName = do - argumentValue <- ActionT $ lift $ asks $ lookup . arguments + argumentValue <- ResolverT $ lift $ asks $ lookup . arguments pure $ fromMaybe Null argumentValue where lookup (Arguments argumentMap) = HashMap.lookup argumentName argumentMap diff --git a/src/Language/GraphQL/Type/Out.hs b/src/Language/GraphQL/Type/Out.hs index 856c4f8..0f14ce8 100644 --- a/src/Language/GraphQL/Type/Out.hs +++ b/src/Language/GraphQL/Type/Out.hs @@ -10,7 +10,6 @@ module Language.GraphQL.Type.Out ( Field(..) , InterfaceType(..) , ObjectType(..) - , Resolver(..) , Type(..) , UnionType(..) , isNonNullType @@ -29,21 +28,12 @@ import Language.GraphQL.Trans import Language.GraphQL.Type.Definition import qualified Language.GraphQL.Type.In as In --- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error --- information (if an error has occurred). @m@ is an arbitrary monad, usually --- 'IO'. --- --- Resolving a field can result in a leaf value or an object, which is --- represented as a list of nested resolvers, used to resolve the fields of that --- object. -data Resolver m = Resolver (Field m) (ActionT m Value) - -- | Object type definition. -- --- Almost all of the GraphQL types you define will be object types. Object --- types have a name, but most importantly describe their fields. +-- Almost all of the GraphQL types you define will be object types. Object +-- types have a name, but most importantly describe their fields. data ObjectType m = ObjectType - Name (Maybe Text) [InterfaceType m] (HashMap Name (Resolver m)) + Name (Maybe Text) [InterfaceType m] (HashMap Name (Field m)) instance forall a. Eq (ObjectType a) where (ObjectType this _ _ _) == (ObjectType that _ _ _) = this == that @@ -73,6 +63,7 @@ data Field m = Field (Maybe Text) -- ^ Description. (Type m) -- ^ Field type. (HashMap Name In.Argument) -- ^ Arguments. + (ResolverT m Value) -- ^ Resolver. -- | These types may be used as output types as the result of fields. -- diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs index 4d7b9eb..4420cbb 100644 --- a/src/Language/GraphQL/Type/Schema.hs +++ b/src/Language/GraphQL/Type/Schema.hs @@ -61,7 +61,7 @@ collectReferencedTypes schema = collect traverser typeName element foundTypes | HashMap.member typeName foundTypes = foundTypes | otherwise = traverser $ HashMap.insert typeName element foundTypes - visitFields (Out.Field _ outputType arguments) foundTypes + visitFields (Out.Field _ outputType arguments _) foundTypes = traverseOutputType outputType $ foldr visitArguments foundTypes arguments visitArguments (In.Argument _ inputType _) = traverseInputType inputType @@ -96,9 +96,8 @@ collectReferencedTypes schema = let (Definition.EnumType typeName _ _) = enumType in collect Prelude.id typeName (EnumType enumType) traverseObjectType objectType foundTypes = - let (Out.ObjectType typeName _ interfaces resolvers) = objectType + let (Out.ObjectType typeName _ interfaces fields) = objectType element = ObjectType objectType - fields = extractObjectField <$> resolvers traverser = polymorphicTraverser interfaces fields in collect traverser typeName element foundTypes traverseInterfaceType interfaceType foundTypes = @@ -109,4 +108,3 @@ collectReferencedTypes schema = polymorphicTraverser interfaces fields = flip (foldr visitFields) fields . flip (foldr traverseInterfaceType) interfaces - extractObjectField (Out.Resolver field _) = field -- cgit v1.2.3