Support subscriptions

This is experimental support.
The implementation is based on conduit and is boring. There is a new
resolver data constructor that should create a source event stream. The
executor receives the events, pipes them through the normal execution
and puts them into the response stream which is returned to the user.

- Tests are missing.
- The executor should check field value resolver on subscription types.
- The graphql function should probably return (Either
  ResponseEventStream Response), but I'm not sure about this. It will
  make the usage more complicated if no subscriptions are involved, but
  with the current API implementing subscriptions is more
  difficult than it should be.

CHANGELOG.md

@@ -22,16 +22,21 @@ and this project adheres to
 - `Error.Response` represents a result of running a GraphQL query.
 - `Type.Schema` exports `Type` which lists all types possible in the schema.
 - Parsing subscriptions (the execution always fails yet).
+- `Error.ResponseEventStream`, `Type.Out.Resolve`, `Type.Out.Subscribe` and
+  `Type.Out.SourceEventStream` define subscription resolvers.
 
 ## Changed
-- `Trans.ActionT` has become to `Type.Out.ResolverT`. Since `Type.Out.Resolver`
+- `Type.Out.Resolver`: Interface fields don't have resolvers, object fields
-  has gone it is a better name for GraphQL resolvers.
+  have value resolvers, root subscription type resolvers need an additional
+  resolver that creates an event stream. `Resolver` represents these differences
+  now and pairs a field with the function(s).
 - All code from `Trans` is moved to `Type.Out` and exported by `Type` and
   `Type.Out`.
 - `AST.Core` contained only `Arguments` which was moved to `Type.Definition`.
   `AST` provides now only functionality related to parsing and encoding, as it
   should be.
-- `Execute.execute` takes an additional argument, a possible operation name.
+- `Execute.execute` takes an additional argument, a possible operation name
+  and returns either a stream or the response.
 - `Error` module was changed to work with dedicated types for errors and the
   response instead of JSON.
 - `graphqlSubs` takes an additional argument, the operation name. The type of
@@ -40,7 +45,9 @@ and this project adheres to
   underlying functions (in the `Execute` module).
 
 ## Removed
-- `Type.Out.Resolver`: It is an unneeded layer of complexity. Resolvers are a
+- `Trans.ActionT` is an unneeded layer of complexity. `Type.Out.Resolver`
+  represents possible resolver configurations.
+- `Type.Out.Resolver`: It . Resolvers are a
   part of the fields and are called `Trans.ResolverT`.
 - `Execute.executeWithName`. `Execute.execute` takes the operation name and
    completely replaces `executeWithName`.

graphql.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: c06170c5fd3d1c3e42fb8c8fde8afd88bf3dd142f6cee1f83128e8d00d443f2d
+-- hash: 38e16611476c6163a049a4ddbaef34cf3fdef8f85d25f7bcaed839372c9fdf75
 
 name:           graphql
 version:        0.8.0.0
@@ -53,6 +53,7 @@ library
       Language.GraphQL.Type.Schema
   other-modules:
       Language.GraphQL.Execute.Execution
+      Language.GraphQL.Execute.Subscribe
       Language.GraphQL.Execute.Transform
       Language.GraphQL.Type.Definition
       Language.GraphQL.Type.Internal
@@ -61,6 +62,7 @@ library
   build-depends:
       aeson
     , base >=4.7 && <5
+    , conduit
     , containers
     , megaparsec
     , parser-combinators
@@ -68,7 +70,6 @@ library
     , text
     , transformers
     , unordered-containers
-    , vector
   default-language: Haskell2010
 
 test-suite tasty
@@ -97,6 +98,7 @@ test-suite tasty
       QuickCheck
     , aeson
     , base >=4.7 && <5
+    , conduit
     , containers
     , graphql
     , hspec
@@ -109,5 +111,4 @@ test-suite tasty
     , text
     , transformers
     , unordered-containers
-    , vector
   default-language: Haskell2010

package.yaml

@@ -28,6 +28,7 @@ data-files:
 dependencies:
 - aeson
 - base >= 4.7 && < 5
+- conduit
 - containers
 - megaparsec
 - parser-combinators
@@ -35,12 +36,12 @@ dependencies:
 - text
 - transformers
 - unordered-containers
-- vector
 
 library:
   source-dirs: src
   other-modules:
   - Language.GraphQL.Execute.Execution
+  - Language.GraphQL.Execute.Subscribe
   - Language.GraphQL.Execute.Transform
   - Language.GraphQL.Type.Definition
   - Language.GraphQL.Type.Internal

src/Language/GraphQL.hs

@@ -9,6 +9,7 @@ module Language.GraphQL
 
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson
+import Data.Either (fromRight)
 import qualified Data.Sequence as Seq
 import Data.Text (Text)
 import Language.GraphQL.AST
@@ -34,10 +35,14 @@ graphqlSubs :: Monad m
     -> Aeson.Object -- ^ Variable substitution function.
     -> Text -- ^ Text representing a @GraphQL@ request document.
     -> m Aeson.Value -- ^ Response.
-graphqlSubs schema operationName variableValues document' =
+graphqlSubs schema operationName variableValues document'
-    either parseError executeRequest parsed >>= formatResponse
+    = either parseError executeRequest (parse document "" document')
+    >>= formatResponse
   where
-    parsed = parse document "" document'
+    executeRequest parsed
+      = fromRight streamReturned
+      <$> execute schema operationName variableValues parsed
+    streamReturned = singleError "This service does not support subscriptions."
     formatResponse (Response data'' Seq.Empty) =
         pure $ Aeson.object [("data", data'')]
     formatResponse (Response data'' errors') = pure $ Aeson.object
@@ -54,4 +59,3 @@ graphqlSubs schema operationName variableValues document' =
         [ ("line", Aeson.toJSON line)
         , ("column", Aeson.toJSON column)
         ]
-    executeRequest = execute schema operationName variableValues

src/Language/GraphQL/Error.hs

@@ -9,19 +9,20 @@ module Language.GraphQL.Error
     , Error(..)
     , Resolution(..)
     , Response(..)
+    , ResponseEventStream
     , addErr
     , addErrMsg
     , runCollectErrs
     , singleError
     ) where
 
+import Conduit
 import Control.Monad.Trans.State (StateT, modify, runStateT)
 import Data.HashMap.Strict (HashMap)
 import Data.Sequence (Seq(..), (|>))
 import qualified Data.Sequence as Seq
 import Data.Text (Text)
 import qualified Data.Text as Text
-import Data.Void (Void)
 import Language.GraphQL.AST (Location(..), Name)
 import Language.GraphQL.Execute.Coerce
 import Language.GraphQL.Type.Schema
@@ -96,6 +97,11 @@ data Response a = Response
     , errors :: Seq Error
     } deriving (Eq, Show)
 
+-- | Each event in the underlying Source Stream triggers execution of the
+-- subscription selection set. The results of the execution generate a Response
+-- Stream.
+type ResponseEventStream m a = ConduitT () (Response a) m ()
+
 -- | Runs the given query computation, but collects the errors into an error
 -- list, which is then sent back with the data.
 runCollectErrs :: (Monad m, Serialize a)

src/Language/GraphQL/Execute.hs

@@ -7,13 +7,13 @@ module Language.GraphQL.Execute
     ) where
 
 import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
 import Data.Sequence (Seq(..))
 import Data.Text (Text)
 import Language.GraphQL.AST.Document (Document, Name)
 import Language.GraphQL.Execute.Coerce
 import Language.GraphQL.Execute.Execution
 import qualified Language.GraphQL.Execute.Transform as Transform
+import qualified Language.GraphQL.Execute.Subscribe as Subscribe
 import Language.GraphQL.Error
 import qualified Language.GraphQL.Type.Definition as Definition
 import qualified Language.GraphQL.Type.Out as Out
@@ -28,24 +28,28 @@ import Language.GraphQL.Type.Schema
 execute :: (Monad m, VariableValue a, Serialize b)
     => Schema m -- ^ Resolvers.
     -> Maybe Text -- ^ Operation name.
-    -> HashMap.HashMap Name a -- ^ Variable substitution function.
+    -> HashMap Name a -- ^ Variable substitution function.
     -> Document -- @GraphQL@ document.
-    -> m (Response b)
+    -> m (Either (ResponseEventStream m b) (Response b))
 execute schema operationName subs document =
     case Transform.document schema operationName subs document of
-        Left queryError -> pure $ singleError $ Transform.queryError queryError
+        Left queryError -> pure
+            $ Right
+            $ singleError
+            $ Transform.queryError queryError
         Right transformed -> executeRequest transformed
 
 executeRequest :: (Monad m, Serialize a)
     => Transform.Document m
-    -> m (Response a)
+    -> m (Either (ResponseEventStream m a) (Response a))
 executeRequest (Transform.Document types' rootObjectType operation)
     | (Transform.Query _ fields) <- operation =
-        executeOperation types' rootObjectType fields
+        Right <$> executeOperation types' rootObjectType fields
     | (Transform.Mutation _ fields) <- operation =
-        executeOperation types' rootObjectType fields
+        Right <$> executeOperation types' rootObjectType fields
-    | otherwise =
+    | (Transform.Subscription _ fields) <- operation
-        pure $ singleError "This service does not support subscriptions."
+        = either (Right . singleError) Left
+        <$> Subscribe.subscribe types' rootObjectType fields
 
 -- This is actually executeMutation, but we don't distinguish between queries
 -- and mutations yet.

src/Language/GraphQL/Execute/Execution.hs

@@ -3,7 +3,9 @@
 {-# LANGUAGE ViewPatterns #-}
 
 module Language.GraphQL.Execute.Execution
-    ( executeSelectionSet
+    ( coerceArgumentValues
+    , collectFields
+    , executeSelectionSet
     ) where
 
 import Control.Monad.Trans.Class (lift)
@@ -32,10 +34,10 @@ import Prelude hiding (null)
 resolveFieldValue :: Monad m
     => Type.Value
     -> Type.Subs
-    -> Type.ResolverT m a
+    -> Type.Resolve m
-    -> m (Either Text a)
+    -> m (Either Text Type.Value)
-resolveFieldValue result args =
+resolveFieldValue result args resolver =
-    flip runReaderT context . runExceptT . Type.runResolverT
+    flip runReaderT context $ runExceptT resolver
   where
     context = Type.Context
         { Type.arguments = Type.Arguments args
@@ -101,12 +103,12 @@ instanceOf objectType (AbstractUnionType unionType) =
     go unionMemberType acc = acc || objectType == unionMemberType
 
 executeField :: (Monad m, Serialize a)
-    => Out.Field m
+    => Out.Resolver m
     -> Type.Value
     -> NonEmpty (Transform.Field m)
     -> CollectErrsT m a
-executeField fieldDefinition prev fields = do
+executeField (Out.ValueResolver fieldDefinition resolver) prev fields = do
-    let Out.Field _ fieldType argumentDefinitions resolver = fieldDefinition
+    let Out.Field _ fieldType argumentDefinitions = fieldDefinition
     let (Transform.Field _ _ arguments' _ :| []) = fields
     case coerceArgumentValues argumentDefinitions arguments' of
         Nothing -> addErrMsg "Argument coercing failed."
@@ -115,6 +117,7 @@ executeField fieldDefinition prev fields = do
             case answer of
                 Right result -> completeValue fieldType fields result
                 Left errorMessage -> addErrMsg errorMessage
+executeField _ _ _ = addErrMsg "No field value resolver specified."
 
 completeValue :: (Monad m, Serialize a)
     => Out.Type m

src/Language/GraphQL/Execute/Subscribe.hs

@@ -0,0 +1,92 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Language.GraphQL.Execute.Subscribe
+    ( subscribe
+    ) where
+
+import Conduit
+import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
+import Control.Monad.Trans.Reader (ReaderT(..), runReaderT)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Map.Strict as Map
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Sequence (Seq(..))
+import Data.Text (Text)
+import Language.GraphQL.AST (Name)
+import Language.GraphQL.Execute.Coerce
+import Language.GraphQL.Execute.Execution
+import qualified Language.GraphQL.Execute.Transform as Transform
+import Language.GraphQL.Error
+import qualified Language.GraphQL.Type.Definition as Definition
+import qualified Language.GraphQL.Type as Type
+import qualified Language.GraphQL.Type.Out as Out
+import Language.GraphQL.Type.Schema
+
+-- This is actually executeMutation, but we don't distinguish between queries
+-- and mutations yet.
+subscribe :: (Monad m, Serialize a)
+    => HashMap Name (Type m)
+    -> Out.ObjectType m
+    -> Seq (Transform.Selection m)
+    -> m (Either Text (ResponseEventStream m a))
+subscribe types' objectType fields = do
+    sourceStream <- createSourceEventStream types' objectType fields
+    traverse (mapSourceToResponseEvent types' objectType fields) sourceStream
+
+mapSourceToResponseEvent :: (Monad m, Serialize a)
+    => HashMap Name (Type m)
+    -> Out.ObjectType m
+    -> Seq (Transform.Selection m)
+    -> Out.SourceEventStream m
+    -> m (ResponseEventStream m a)
+mapSourceToResponseEvent types' subscriptionType fields sourceStream = pure
+    $ sourceStream
+    .| mapMC (executeSubscriptionEvent types' subscriptionType fields)
+
+createSourceEventStream :: Monad m
+    => HashMap Name (Type m)
+    -> Out.ObjectType m
+    -> Seq (Transform.Selection m)
+    -> m (Either Text (Out.SourceEventStream m))
+createSourceEventStream _types subscriptionType@(Out.ObjectType _ _ _ fieldTypes) fields
+    | [fieldGroup] <- Map.elems groupedFieldSet
+    , Transform.Field _ fieldName arguments' _ <- NonEmpty.head fieldGroup
+    , resolverT <- fieldTypes HashMap.! fieldName
+    , Out.EventStreamResolver fieldDefinition _ resolver <- resolverT
+    , Out.Field _ _fieldType argumentDefinitions <- fieldDefinition =
+        case coerceArgumentValues argumentDefinitions arguments' of
+            Nothing -> pure $ Left "Argument coercion failed."
+            Just argumentValues ->
+                resolveFieldEventStream Type.Null argumentValues resolver
+    | otherwise = pure $ Left "Subscription contains more than one field."
+  where
+    groupedFieldSet = collectFields subscriptionType fields
+
+resolveFieldEventStream :: Monad m
+    => Type.Value
+    -> Type.Subs
+    -> ExceptT Text (ReaderT Out.Context m) (Out.SourceEventStream m)
+    -> m (Either Text (Out.SourceEventStream m))
+resolveFieldEventStream result args resolver =
+    flip runReaderT context $ runExceptT resolver
+  where
+    context = Type.Context
+        { Type.arguments = Type.Arguments args
+        , Type.values = result
+        }
+
+-- This is actually executeMutation, but we don't distinguish between queries
+-- and mutations yet.
+executeSubscriptionEvent :: (Monad m, Serialize a)
+    => HashMap Name (Type m)
+    -> Out.ObjectType m
+    -> Seq (Transform.Selection m)
+    -> Definition.Value
+    -> m (Response a)
+executeSubscriptionEvent types' objectType fields initialValue =
+    runCollectErrs types' $ executeSelectionSet initialValue objectType fields

src/Language/GraphQL/Type.hs

@@ -1,3 +1,7 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
 -- | Reexports non-conflicting type system and schema definitions.
 module Language.GraphQL.Type
     ( In.InputField(..)
@@ -6,7 +10,10 @@ module Language.GraphQL.Type
     , Out.Field(..)
     , Out.InterfaceType(..)
     , Out.ObjectType(..)
-    , Out.ResolverT(..)
+    , Out.Resolve
+    , Out.Resolver(..)
+    , Out.SourceEventStream
+    , Out.Subscribe
     , Out.UnionType(..)
     , Out.argument
     , module Language.GraphQL.Type.Definition

src/Language/GraphQL/Type/Internal.hs

@@ -1,3 +1,7 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
 {-# LANGUAGE ExplicitForAll #-}
 
 module Language.GraphQL.Type.Internal
@@ -36,11 +40,13 @@ 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
     visitInputFields (In.InputField _ inputType _) = traverseInputType inputType
+    getField (Out.ValueResolver field _) = field
+    getField (Out.EventStreamResolver field _ _) = field
     traverseInputType (In.InputObjectBaseType objectType) =
         let (In.InputObjectType typeName _ inputFields) = objectType
             element = InputObjectType objectType
@@ -73,7 +79,7 @@ collectReferencedTypes schema =
     traverseObjectType objectType foundTypes =
         let (Out.ObjectType typeName _ interfaces fields) = objectType
             element = ObjectType objectType
-            traverser = polymorphicTraverser interfaces fields
+            traverser = polymorphicTraverser interfaces (getField <$> fields)
          in collect traverser typeName element foundTypes
     traverseInterfaceType interfaceType foundTypes =
         let (Out.InterfaceType typeName _ interfaces fields) = interfaceType

src/Language/GraphQL/Type/Out.hs

@@ -1,3 +1,7 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
 {-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ViewPatterns #-}
@@ -12,7 +16,10 @@ module Language.GraphQL.Type.Out
     , Field(..)
     , InterfaceType(..)
     , ObjectType(..)
-    , ResolverT(..)
+    , Resolve
+    , Subscribe
+    , Resolver(..)
+    , SourceEventStream
     , Type(..)
     , UnionType(..)
     , argument
@@ -25,10 +32,7 @@ module Language.GraphQL.Type.Out
     , pattern UnionBaseType
     ) where
 
-import Control.Applicative (Alternative(..))
+import Conduit
-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)
@@ -44,7 +48,7 @@ import qualified Language.GraphQL.Type.In as In
 -- 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 (Field m))
+    Name (Maybe Text) [InterfaceType m] (HashMap Name (Resolver m))
 
 instance forall a. Eq (ObjectType a) where
     (ObjectType this _ _ _) == (ObjectType that _ _ _) = this == that
@@ -74,7 +78,6 @@ 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.
 --
@@ -169,56 +172,41 @@ isNonNullType (NonNullUnionType _) = True
 isNonNullType (NonNullListType _) = True
 isNonNullType _ = False
 
--- | Resolution context holds resolver arguments.
+-- | Resolution context holds resolver arguments and the root value.
 data Context = Context
     { arguments :: Arguments
     , values :: Value
     }
 
--- | Monad transformer stack used by the resolvers to provide error handling
+-- | Monad transformer stack used by the resolvers for determining the resolved
--- and resolution context (resolver arguments).
+-- value of a field.
+type Resolve m = ExceptT Text (ReaderT Context m) Value
+
+-- | Monad transformer stack used by the resolvers for determining the resolved
+-- event stream of a subscription field.
+type Subscribe m = ExceptT Text (ReaderT Context m) (SourceEventStream m)
+
+-- | A source stream represents the sequence of events, each of which will
+-- trigger a GraphQL execution corresponding to that event.
+type SourceEventStream m = ConduitT () Value m ()
+
+-- | 'Resolver' associates some function(s) with each 'Field'. 'ValueResolver'
+-- resolves a 'Field' into a 'Value'. 'EventStreamResolver' resolves
+-- additionally a 'Field' into a 'SourceEventStream' if it is the field of a
+-- root subscription type.
 --
--- Resolves a 'Field' into a 'Value' with error information (if an error has
+-- The resolvers aren't part of the 'Field' itself because not all fields
--- occurred). @m@ is an arbitrary monad, usually 'IO'.
+-- have resolvers (interface fields don't have an implementation).
---
+data Resolver m
--- Resolving a field can result in a leaf value or an object, which is
+    = ValueResolver (Field m) (Resolve m)
--- represented as a list of nested resolvers, used to resolve the fields of that
+    | EventStreamResolver (Field m) (Resolve m) (Subscribe m)
--- 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 :: Monad m => Name -> Resolve m
 argument argumentName = do
-    argumentValue <- ResolverT $ lift $ asks $ lookupArgument . arguments
+    argumentValue <- lift $ asks $ lookupArgument . arguments
     pure $ fromMaybe Null argumentValue
   where
     lookupArgument (Arguments argumentMap) =

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-16.4
+resolver: lts-16.5
 
 packages:
 - .

tests/Language/GraphQL/ExecuteSpec.hs

@@ -5,6 +5,7 @@ module Language.GraphQL.ExecuteSpec
 
 import Data.Aeson ((.=))
 import qualified Data.Aeson as Aeson
+import Data.Either (fromRight)
 import Data.Functor.Identity (Identity(..))
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
@@ -22,26 +23,27 @@ schema = Schema {query = queryType, mutation = Nothing}
 
 queryType :: Out.ObjectType Identity
 queryType = Out.ObjectType "Query" Nothing []
-    $ HashMap.singleton "philosopher" philosopherField
+    $ HashMap.singleton "philosopher" 
+    $ ValueResolver philosopherField
+    $ pure $ Type.Object mempty
   where
-    philosopherField
+    philosopherField =
-        = Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
+        Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
-        $ pure $ Type.Object mempty
 
 philosopherType :: Out.ObjectType Identity
 philosopherType = Out.ObjectType "Philosopher" Nothing []
     $ HashMap.fromList resolvers
   where
     resolvers =
-        [ ("firstName", firstNameField)
+        [ ("firstName", ValueResolver firstNameField firstNameResolver)
-        , ("lastName", lastNameField)
+        , ("lastName", ValueResolver lastNameField lastNameResolver)
         ]
-    firstNameField
+    firstNameField =
-        = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
+        Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
-        $ pure $ Type.String "Friedrich"
+    firstNameResolver = pure $ Type.String "Friedrich"
     lastNameField
         = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
-        $ pure $ Type.String "Nietzsche"
+    lastNameResolver = pure $ Type.String "Nietzsche"
 
 spec :: Spec
 spec =
@@ -54,8 +56,9 @@ spec =
                     ]
                 expected = Response data'' mempty
                 execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
-                actual = runIdentity
+                actual = fromRight (singleError "")
-                    $ either parseError execute'
+                    $ runIdentity
+                    $ either (pure . parseError) execute'
                     $ parse document "" "{ philosopher { firstName surname } }"
              in actual `shouldBe` expected
         it "merges selections" $
@@ -67,7 +70,8 @@ spec =
                     ]
                 expected = Response data'' mempty
                 execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
-                actual = runIdentity
+                actual = fromRight (singleError "")
-                    $ either parseError execute'
+                    $ runIdentity
+                    $ either (pure . parseError) execute'
                     $ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
              in actual `shouldBe` expected

tests/Test/DirectiveSpec.hs

@@ -16,10 +16,10 @@ import Text.RawString.QQ (r)
 experimentalResolver :: Schema IO
 experimentalResolver = Schema { query = queryType, mutation = Nothing }
   where
-    resolver = pure $ Int 5
     queryType = Out.ObjectType "Query" Nothing []
         $ HashMap.singleton "experimentalField"
-        $ Out.Field Nothing (Out.NamedScalarType int) mempty resolver
+        $ Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
+        $ pure $ Int 5
 
 emptyObject :: Aeson.Value
 emptyObject = object

tests/Test/FragmentSpec.hs

@@ -64,12 +64,14 @@ hatType = Out.ObjectType "Hat" Nothing []
         , ("circumference", circumferenceFieldType)
         ]
 
-circumferenceFieldType :: Out.Field IO
+circumferenceFieldType :: Out.Resolver IO
-circumferenceFieldType = Out.Field Nothing (Out.NamedScalarType int) mempty
+circumferenceFieldType
+    = Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
     $ pure $ snd circumference
 
-sizeFieldType :: Out.Field IO
+sizeFieldType :: Out.Resolver IO
-sizeFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+sizeFieldType
+    = Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
     $ pure $ snd size
 
 toSchema :: Text -> (Text, Value) -> Schema IO
@@ -78,17 +80,15 @@ toSchema t (_, resolve) = Schema
   where
     unionMember = if t == "Hat" then hatType else shirtType
     typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty
-        $ pure $ String "Shirt"
     garmentField = Out.Field Nothing (Out.NamedObjectType unionMember) mempty
-        $ pure resolve
     queryType =
         case t of
             "circumference" -> hatType
             "size" -> shirtType
             _ -> Out.ObjectType "Query" Nothing []
                 $ HashMap.fromList
-                    [ ("garment", garmentField)
+                    [ ("garment", ValueResolver garmentField (pure resolve))
-                    , ("__typename", typeNameField)
+                    , ("__typename", ValueResolver typeNameField (pure $ String "Shirt"))
                     ]
 
 spec :: Spec

tests/Test/RootOperationSpec.hs

@@ -15,23 +15,23 @@ import qualified Language.GraphQL.Type.Out as Out
 hatType :: Out.ObjectType IO
 hatType = Out.ObjectType "Hat" Nothing []
     $ HashMap.singleton "circumference"
-    $ Out.Field Nothing (Out.NamedScalarType int) mempty
+    $ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
-    $ pure
+    $ pure $ Int 60
-    $ Int 60
 
 schema :: Schema IO
 schema = Schema
-    (Out.ObjectType "Query" Nothing [] hatField)
+    (Out.ObjectType "Query" Nothing [] hatFieldResolver)
-    (Just $ Out.ObjectType "Mutation" Nothing [] incrementField)
+    (Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver)
   where
     garment = pure $ Object $ HashMap.fromList
         [ ("circumference", Int 60)
         ]
-    incrementField = HashMap.singleton "incrementCircumference"
+    incrementFieldResolver = HashMap.singleton "incrementCircumference"
-        $ Out.Field Nothing (Out.NamedScalarType int) mempty
+        $ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
         $ pure $ Int 61
-    hatField = HashMap.singleton "garment"
+    hatField = Out.Field Nothing (Out.NamedObjectType hatType) mempty
-        $ Out.Field Nothing (Out.NamedObjectType hatType) mempty garment
+    hatFieldResolver =
+        HashMap.singleton "garment" $ ValueResolver hatField garment
 
 spec :: Spec
 spec =

tests/Test/StarWars/Data.hs

@@ -66,8 +66,8 @@ appearsIn :: Character -> [Int]
 appearsIn (Left  x) = _appearsIn . _droidChar $ x
 appearsIn (Right x) = _appearsIn . _humanChar $ x
 
-secretBackstory :: ResolverT Identity Text
+secretBackstory :: Resolve Identity
-secretBackstory = ResolverT $ throwE "secretBackstory is secret."
+secretBackstory = throwE "secretBackstory is secret."
 
 typeName :: Character -> Text
 typeName = either (const "Droid") (const "Human")
@@ -161,10 +161,10 @@ getHero :: Int -> Character
 getHero 5 = luke
 getHero _ = artoo
 
-getHuman :: Alternative f => ID -> f Character
+getHuman :: ID -> Maybe Character
 getHuman = fmap Right . getHuman'
 
-getHuman' :: Alternative f => ID -> f Human
+getHuman' :: ID -> Maybe Human
 getHuman' "1000" = pure luke'
 getHuman' "1001" = pure vader
 getHuman' "1002" = pure han
@@ -172,10 +172,10 @@ getHuman' "1003" = pure leia
 getHuman' "1004" = pure tarkin
 getHuman' _      = empty
 
-getDroid :: Alternative f => ID -> f Character
+getDroid :: ID -> Maybe Character
 getDroid = fmap Left . getDroid'
 
-getDroid' :: Alternative f => ID -> f Droid
+getDroid' :: ID -> Maybe Droid
 getDroid' "2000" = pure threepio
 getDroid' "2001" = pure artoo'
 getDroid' _      = empty

tests/Test/StarWars/Schema.hs

@@ -23,19 +23,20 @@ schema :: Schema Identity
 schema = Schema { query = queryType, mutation = Nothing }
   where
     queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
-        [ ("hero", heroField)
+        [ ("hero", heroFieldResolver)
-        , ("human", humanField)
+        , ("human", humanFieldResolver)
-        , ("droid", droidField)
+        , ("droid", droidFieldResolver)
         ]
-    heroArguments = HashMap.singleton "episode"
+    heroField = Out.Field Nothing (Out.NamedObjectType heroObject)
+        $ HashMap.singleton "episode"
         $ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing
-    heroField =
+    heroFieldResolver = ValueResolver heroField hero
-        Out.Field Nothing (Out.NamedObjectType heroObject) heroArguments hero
+    humanField = Out.Field Nothing (Out.NamedObjectType heroObject)
-    humanArguments = HashMap.singleton "id"
+        $ HashMap.singleton "id"
         $ In.Argument Nothing (In.NonNullScalarType string) Nothing
-    humanField =
+    humanFieldResolver = ValueResolver humanField human
-        Out.Field Nothing (Out.NamedObjectType heroObject) humanArguments human
+    droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty
-    droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty droid
+    droidFieldResolver = ValueResolver droidField droid
 
 heroObject :: Out.ObjectType Identity
 heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
@@ -48,8 +49,9 @@ heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
     , ("__typename", typenameFieldType)
     ]
   where
-    homePlanetFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+    homePlanetFieldType
-        $ idField "homePlanet"
+      = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+      $ idField "homePlanet"
 
 droidObject :: Out.ObjectType Identity
 droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
@@ -62,39 +64,48 @@ droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
     , ("__typename", typenameFieldType)
     ]
   where
-    primaryFunctionFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+    primaryFunctionFieldType
+        = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
         $ idField "primaryFunction"
 
-typenameFieldType :: Out.Field Identity
+typenameFieldType :: Resolver Identity
-typenameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+typenameFieldType
+    = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
     $ idField "__typename"
 
-idFieldType :: Out.Field Identity
+idFieldType :: Resolver Identity
-idFieldType = Out.Field Nothing (Out.NamedScalarType id) mempty
+idFieldType
+    = ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty)
     $ idField "id"
 
-nameFieldType :: Out.Field Identity
+nameFieldType :: Resolver  Identity
-nameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+nameFieldType
+    = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
     $ idField "name"
 
-friendsFieldType :: Out.Field Identity
+friendsFieldType :: Resolver Identity
-friendsFieldType = Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty
+friendsFieldType
+    = ValueResolver (Out.Field Nothing fieldType mempty)
     $ idField "friends"
+  where
+    fieldType = Out.ListType $ Out.NamedObjectType droidObject
 
-appearsInField :: Out.Field Identity
+appearsInField :: Resolver Identity
-appearsInField = Out.Field (Just description) fieldType mempty
+appearsInField
+    = ValueResolver (Out.Field (Just description) fieldType mempty)
     $ idField "appearsIn"
   where
     fieldType = Out.ListType $ Out.NamedEnumType episodeEnum
     description = "Which movies they appear in."
 
-secretBackstoryFieldType :: Out.Field Identity
+secretBackstoryFieldType :: Resolver Identity
-secretBackstoryFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+secretBackstoryFieldType = ValueResolver field secretBackstory
-    $ String <$> secretBackstory
+  where
+    field = Out.Field Nothing (Out.NamedScalarType string) mempty
 
-idField :: Text -> ResolverT Identity Value
+idField :: Text -> Resolve Identity
 idField f = do
-    v <- ResolverT $ lift $ asks values
+    v <- lift $ asks values
     let (Object v') = v
     pure $ v' HashMap.! f
 
@@ -107,7 +118,7 @@ episodeEnum = EnumType "Episode" (Just description)
     empire = ("EMPIRE", EnumValue $ Just "Released in 1980.")
     jedi = ("JEDI", EnumValue $ Just "Released in 1983.")
 
-hero :: ResolverT Identity Value
+hero :: Resolve Identity
 hero = do
   episode <- argument "episode"
   pure $ character $ case episode of
@@ -116,23 +127,19 @@ hero = do
       Enum "JEDI" -> getHero 6
       _ -> artoo
 
-human :: ResolverT Identity Value
+human :: Resolve Identity
 human = do
     id' <- argument "id"
     case id' of
-        String i -> do
+        String i -> pure $ maybe Null character $ getHuman i >>= Just
-            humanCharacter <- lift $ return $ getHuman i >>= Just
+        _ -> throwE "Invalid arguments."
-            case humanCharacter of
-                Nothing -> pure Null
-                Just e -> pure $ character e
-        _ -> ResolverT $ throwE "Invalid arguments."
 
-droid :: ResolverT Identity Value
+droid :: Resolve Identity
 droid = do
     id' <- argument "id"
     case id' of
-        String i -> character <$> getDroid i
+        String i -> pure $ maybe Null character $ getDroid i >>= Just
-        _ -> ResolverT $ throwE "Invalid arguments."
+        _ -> throwE "Invalid arguments."
 
 character :: Character -> Value
 character char = Object $ HashMap.fromList