From 2f4310268a12e46911e3c3e9c2044ad1e46ae9f6 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Thu, 2 Jul 2020 07:33:03 +0200 Subject: Merge Trans and Type.Out modules --- src/Language/GraphQL/Execute/Execution.hs | 12 ++--- src/Language/GraphQL/Trans.hs | 73 ------------------------------- src/Language/GraphQL/Type.hs | 3 ++ src/Language/GraphQL/Type/Out.hs | 72 ++++++++++++++++++++++++++++-- 4 files changed, 79 insertions(+), 81 deletions(-) delete mode 100644 src/Language/GraphQL/Trans.hs (limited to 'src') diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs index 5e53311..2b12c43 100644 --- a/src/Language/GraphQL/Execute/Execution.hs +++ b/src/Language/GraphQL/Execute/Execution.hs @@ -22,7 +22,6 @@ import Language.GraphQL.AST (Name) import Language.GraphQL.Error import Language.GraphQL.Execute.Coerce import qualified Language.GraphQL.Execute.Transform as Transform -import Language.GraphQL.Trans import qualified Language.GraphQL.Type as Type import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out @@ -32,12 +31,15 @@ import Prelude hiding (null) resolveFieldValue :: Monad m => Type.Value -> Type.Subs - -> ResolverT m a + -> Type.ResolverT m a -> m (Either Text a) resolveFieldValue result args = - flip runReaderT (Context {arguments = Type.Arguments args, values = result}) - . runExceptT - . runResolverT + flip runReaderT context . runExceptT . Type.runResolverT + where + context = Type.Context + { Type.arguments = Type.Arguments args + , Type.values = result + } collectFields :: Monad m => Out.ObjectType m diff --git a/src/Language/GraphQL/Trans.hs b/src/Language/GraphQL/Trans.hs deleted file mode 100644 index a55ac49..0000000 --- a/src/Language/GraphQL/Trans.hs +++ /dev/null @@ -1,73 +0,0 @@ --- | Monad transformer stack used by the @GraphQL@ resolvers. -module Language.GraphQL.Trans - ( argument - , ResolverT(..) - , Context(..) - ) where - -import Control.Applicative (Alternative(..)) -import Control.Monad (MonadPlus(..)) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Trans.Except (ExceptT) -import Control.Monad.Trans.Reader (ReaderT, asks) -import qualified Data.HashMap.Strict as HashMap -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Language.GraphQL.AST (Name) -import Language.GraphQL.Type.Definition -import Prelude hiding (lookup) - --- | Resolution context holds resolver arguments. -data Context = Context - { arguments :: Arguments - , values :: Value - } - --- | Monad transformer stack used by the resolvers to provide error handling --- 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 (ResolverT m) where - fmap f = ResolverT . fmap f . runResolverT - -instance Monad m => Applicative (ResolverT m) where - pure = ResolverT . pure - (ResolverT f) <*> (ResolverT x) = ResolverT $ f <*> x - -instance Monad m => Monad (ResolverT m) where - return = pure - (ResolverT action) >>= f = ResolverT $ action >>= runResolverT . f - -instance MonadTrans ResolverT where - lift = ResolverT . lift . lift - -instance MonadIO m => MonadIO (ResolverT m) where - liftIO = lift . liftIO - -instance Monad m => Alternative (ResolverT m) where - empty = ResolverT empty - (ResolverT x) <|> (ResolverT y) = ResolverT $ x <|> y - -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 -> ResolverT m Value -argument argumentName = do - 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.hs b/src/Language/GraphQL/Type.hs index 5dfd622..0a30924 100644 --- a/src/Language/GraphQL/Type.hs +++ b/src/Language/GraphQL/Type.hs @@ -2,10 +2,13 @@ module Language.GraphQL.Type ( In.InputField(..) , In.InputObjectType(..) + , Out.Context(..) , Out.Field(..) , Out.InterfaceType(..) , Out.ObjectType(..) + , Out.ResolverT(..) , Out.UnionType(..) + , Out.argument , module Language.GraphQL.Type.Definition , module Language.GraphQL.Type.Schema ) where diff --git a/src/Language/GraphQL/Type/Out.hs b/src/Language/GraphQL/Type/Out.hs index 0f14ce8..97107ca 100644 --- a/src/Language/GraphQL/Type/Out.hs +++ b/src/Language/GraphQL/Type/Out.hs @@ -2,16 +2,20 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} --- | Output types and values. +-- | Output types and values, monad transformer stack used by the @GraphQL@ +-- resolvers. -- -- This module is intended to be imported qualified, to avoid name clashes -- with 'Language.GraphQL.Type.In'. module Language.GraphQL.Type.Out - ( Field(..) + ( Context(..) + , Field(..) , InterfaceType(..) , ObjectType(..) + , ResolverT(..) , Type(..) , UnionType(..) + , argument , isNonNullType , pattern EnumBaseType , pattern InterfaceBaseType @@ -21,10 +25,17 @@ module Language.GraphQL.Type.Out , pattern UnionBaseType ) where +import Control.Applicative (Alternative(..)) +import Control.Monad (MonadPlus(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Reader (ReaderT, asks) import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Maybe (fromMaybe) import Data.Text (Text) import Language.GraphQL.AST (Name) -import Language.GraphQL.Trans import Language.GraphQL.Type.Definition import qualified Language.GraphQL.Type.In as In @@ -157,3 +168,58 @@ isNonNullType (NonNullInterfaceType _) = True isNonNullType (NonNullUnionType _) = True isNonNullType (NonNullListType _) = True isNonNullType _ = False + +-- | Resolution context holds resolver arguments. +data Context = Context + { arguments :: Arguments + , values :: Value + } + +-- | Monad transformer stack used by the resolvers to provide error handling +-- 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 (ResolverT m) where + fmap f = ResolverT . fmap f . runResolverT + +instance Monad m => Applicative (ResolverT m) where + pure = ResolverT . pure + (ResolverT f) <*> (ResolverT x) = ResolverT $ f <*> x + +instance Monad m => Monad (ResolverT m) where + return = pure + (ResolverT action) >>= f = ResolverT $ action >>= runResolverT . f + +instance MonadTrans ResolverT where + lift = ResolverT . lift . lift + +instance MonadIO m => MonadIO (ResolverT m) where + liftIO = lift . liftIO + +instance Monad m => Alternative (ResolverT m) where + empty = ResolverT empty + (ResolverT x) <|> (ResolverT y) = ResolverT $ x <|> y + +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 -> ResolverT m Value +argument argumentName = do + argumentValue <- ResolverT $ lift $ asks $ lookupArgument . arguments + pure $ fromMaybe Null argumentValue + where + lookupArgument (Arguments argumentMap) = + HashMap.lookup argumentName argumentMap -- cgit v1.2.3