Show the value and expected type in value completion errors

1 files changed, 843 insertions, 53 deletions

diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs
index 62754a3..1ccdee0 100644
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@@ -1,71 +1,861 @@
-{-# LANGUAGE ExplicitForAll #-}
+{- 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 ExistentialQuantification #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 
--- | This module provides functions to execute a @GraphQL@ request.
 module Language.GraphQL.Execute
-    ( execute
-    , module Language.GraphQL.Execute.Coerce
-    ) where
+   ( Error(..)
+   , Operation(..)
+   , Path(..)
+   , Response(..)
+   , execute
+   ) where
 
-import Control.Monad.Catch (MonadCatch)
+import Conduit (mapMC, (.|))
+import Control.Arrow (left)
+import Control.Monad.Catch
+     ( Exception(..)
+     , MonadCatch(..)
+     , MonadThrow(..)
+     , SomeException(..)
+     )
+import Control.Monad.Trans.Class (MonadTrans(..))
+import Control.Monad.Trans.Reader (ReaderT(..), ask, local, runReaderT)
+import Control.Monad.Trans.Writer (WriterT(..), runWriterT, tell)
+import qualified Control.Monad.Trans.Reader as Reader
+import Control.Monad (foldM)
+import qualified Language.GraphQL.AST.Document as Full
+import Data.Bifunctor (first)
+import Data.Foldable (find)
+import Data.Functor ((<&>))
 import Data.HashMap.Strict (HashMap)
-import Data.Sequence (Seq(..))
+import qualified Data.HashMap.Strict as HashMap
+import Data.HashSet (HashSet)
+import qualified Data.HashSet as HashSet
+import Data.Int (Int32)
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Maybe (fromMaybe, isJust)
+import Data.Sequence (Seq, (><))
+import qualified Data.Sequence as Seq
 import Data.Text (Text)
-import qualified Language.GraphQL.AST.Document as Full
-import Language.GraphQL.Execute.Coerce
-import Language.GraphQL.Execute.Execution
-import Language.GraphQL.Execute.Internal
-import qualified Language.GraphQL.Execute.Transform as Transform
-import qualified Language.GraphQL.Execute.Subscribe as Subscribe
+import qualified Data.Text as Text
+import Data.Typeable (cast)
+import qualified Language.GraphQL.Execute.Coerce as Coerce
+import Language.GraphQL.Execute.OrderedMap (OrderedMap)
+import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
+import qualified Language.GraphQL.Type.In as In
+import qualified Language.GraphQL.Type.Out as Out
+import qualified Language.GraphQL.Type as Type
+import qualified Language.GraphQL.Type.Internal as Type.Internal
+import Language.GraphQL.Type.Schema (Schema, Type)
+import qualified Language.GraphQL.Type.Schema as Schema
 import Language.GraphQL.Error
-    ( Error
-    , ResponseEventStream
+    ( Error(..)
     , Response(..)
-    , runCollectErrs
-    )
-import qualified Language.GraphQL.Type.Definition as Definition
-import qualified Language.GraphQL.Type.Out as Out
-import Language.GraphQL.Type.Schema
-import Prelude hiding (null)
-
--- | The substitution is applied to the document, and the resolvers are applied
--- to the resulting fields. The operation name can be used if the document
--- defines multiple root operations.
---
--- Returns the result of the query against the schema wrapped in a /data/
--- field, or errors wrapped in an /errors/ field.
-execute :: (MonadCatch m, VariableValue a, Serialize b)
+   , Path(..)
+   , ResponseEventStream
+   )
+
+data Replacement m = Replacement
+    { variableValues :: Type.Subs
+    , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
+    , visitedFragments :: HashSet Full.Name
+    , types :: HashMap Full.Name (Type m)
+    }
+
+newtype TransformT m a = TransformT
+    { runTransformT :: ReaderT (Replacement m) m a
+    }
+
+instance Functor m => Functor (TransformT m) where
+    fmap f = TransformT . fmap f . runTransformT
+
+instance Applicative m => Applicative (TransformT m) where
+    pure = TransformT . pure
+    TransformT f <*> TransformT x = TransformT $ f <*> x
+
+instance Monad m => Monad (TransformT m) where
+    TransformT x >>= f = TransformT $ x >>= runTransformT . f
+
+instance MonadTrans TransformT where
+    lift = TransformT . lift
+
+instance MonadThrow m => MonadThrow (TransformT m) where
+    throwM = lift . throwM
+
+instance MonadCatch m => MonadCatch (TransformT m) where
+  catch (TransformT stack) handler =
+      TransformT $ catch stack $ runTransformT . handler
+
+newtype ExecutorT m a = ExecutorT
+    { runExecutorT :: ReaderT (HashMap Full.Name (Type m)) (WriterT (Seq Error) m) a
+    }
+
+instance Functor m => Functor (ExecutorT m) where
+    fmap f = ExecutorT . fmap f . runExecutorT
+
+instance Applicative m => Applicative (ExecutorT m) where
+    pure = ExecutorT . pure
+    ExecutorT f <*> ExecutorT x = ExecutorT $ f <*> x
+
+instance Monad m => Monad (ExecutorT m) where
+    ExecutorT x >>= f = ExecutorT $ x >>= runExecutorT . f
+
+instance MonadTrans ExecutorT where
+    lift = ExecutorT . lift . lift
+
+instance MonadThrow m => MonadThrow (ExecutorT m) where
+    throwM = lift . throwM
+
+instance MonadCatch m => MonadCatch (ExecutorT m) where
+  catch (ExecutorT stack) handler =
+      ExecutorT $ catch stack $ runExecutorT . handler
+
+data GraphQLException = forall e. Exception e => GraphQLException e
+
+instance Show GraphQLException where
+    show (GraphQLException e) = show e
+
+instance Exception GraphQLException
+
+graphQLExceptionToException :: Exception e => e -> SomeException
+graphQLExceptionToException = toException . GraphQLException
+
+graphQLExceptionFromException :: Exception e => SomeException -> Maybe e
+graphQLExceptionFromException e = do
+    GraphQLException graphqlException <- fromException e
+    cast graphqlException
+
+data ResolverException = forall e. Exception e => ResolverException e
+
+instance Show ResolverException where
+    show (ResolverException e) = show e
+
+instance Exception ResolverException where
+    toException = graphQLExceptionToException
+    fromException = graphQLExceptionFromException
+
+data FieldError
+    = ArgumentTypeError
+    | MissingArgumentError
+    | ResultCoercionError
+    | NullResultError
+
+instance Show FieldError where
+    show ArgumentTypeError = "Invalid argument type."
+    show MissingArgumentError = "Required argument not specified."
+    show ResultCoercionError = "Result coercion failed."
+    show NullResultError = "Non-Nullable field resolver returned Null."
+
+newtype FieldException = FieldException FieldError
+    deriving Show
+
+instance Exception FieldException where
+   toException = graphQLExceptionToException
+   fromException = graphQLExceptionFromException
+
+data ValueCompletionException = ValueCompletionException String Type.Value
+
+instance Show ValueCompletionException where
+    show (ValueCompletionException typeRepresentation found) = concat
+        [ "Value completion error. Expected type "
+        , typeRepresentation
+        , ", found: "
+        , show found
+        , "."
+        ]
+
+instance Exception ValueCompletionException where
+    toException = graphQLExceptionToException
+    fromException = graphQLExceptionFromException
+
+data QueryError
+   = OperationNameRequired
+   | OperationNotFound String
+   | CoercionError Full.VariableDefinition
+   | UnknownInputType Full.VariableDefinition
+
+asks :: Monad m => forall a. (Replacement m -> a) -> TransformT m a
+asks = TransformT . Reader.asks
+
+queryError :: QueryError -> Error
+queryError OperationNameRequired =
+    Error{ message = "Operation name is required.", locations = [], path = [] }
+queryError (OperationNotFound operationName) =
+    let queryErrorMessage = Text.concat
+            [ "Operation \""
+            , Text.pack operationName
+            , "\" not found."
+            ]
+     in Error{ message = queryErrorMessage, locations = [], path = [] }
+queryError (CoercionError variableDefinition) =
+    let Full.VariableDefinition variableName _ _ location = variableDefinition
+        queryErrorMessage = Text.concat
+            [ "Failed to coerce the variable \""
+            , variableName
+            , "\"."
+            ]
+     in Error{ message = queryErrorMessage, locations = [location], path = [] }
+queryError (UnknownInputType variableDefinition) =
+    let Full.VariableDefinition variableName variableTypeName _ location = variableDefinition
+        queryErrorMessage = Text.concat
+            [ "Variable \""
+            , variableName
+            , "\" has unknown type \""
+            , Text.pack $ show variableTypeName
+            , "\"."
+            ]
+     in Error{ message = queryErrorMessage, locations = [location], path = [] }
+
+data Operation m
+    = Operation Full.OperationType (Seq (Selection m)) Full.Location
+
+data Selection m
+    = FieldSelection (Field m)
+    | FragmentSelection (Fragment m)
+
+data Field m = Field
+    (Maybe Full.Name)
+    Full.Name
+    (HashMap Full.Name (Full.Node Input))
+    (Seq (Selection m))
+    Full.Location
+
+data Fragment m = Fragment
+    (Type.Internal.CompositeType m) (Seq (Selection m)) Full.Location
+
+data Input
+    = Variable Type.Value
+    | Int Int32
+    | Float Double
+    | String Text
+    | Boolean Bool
+    | Null
+    | Enum Full.Name
+    | List [Input]
+    | Object (HashMap Full.Name Input)
+
+document :: Full.Document
+    -> ([Full.OperationDefinition], HashMap Full.Name Full.FragmentDefinition)
+document = foldr filterOperation ([], HashMap.empty)
+  where
+    filterOperation (Full.ExecutableDefinition executableDefinition) accumulator
+        | Full.DefinitionOperation operationDefinition' <- executableDefinition =
+            first (operationDefinition' :) accumulator
+        | Full.DefinitionFragment fragmentDefinition <- executableDefinition
+        , Full.FragmentDefinition fragmentName _ _ _ _ <- fragmentDefinition =
+            HashMap.insert fragmentName fragmentDefinition <$> accumulator
+    filterOperation _ accumulator = accumulator -- Type system definitions.
+
+transform :: Monad m => Full.OperationDefinition -> TransformT m (Operation m)
+transform (Full.OperationDefinition operationType _ _ _ selectionSet' operationLocation) = do
+    transformedSelections <- selectionSet selectionSet'
+    pure $ Operation operationType transformedSelections operationLocation
+transform (Full.SelectionSet selectionSet' operationLocation) = do
+    transformedSelections <- selectionSet selectionSet'
+    pure $ Operation Full.Query transformedSelections operationLocation
+
+selectionSet :: Monad m => Full.SelectionSet -> TransformT m (Seq (Selection m))
+selectionSet = selectionSetOpt . NonEmpty.toList
+
+selectionSetOpt :: Monad m => Full.SelectionSetOpt -> TransformT m (Seq (Selection m))
+selectionSetOpt = foldM go Seq.empty
+  where
+    go accumulatedSelections currentSelection =
+        selection currentSelection <&> (accumulatedSelections ><)
+
+selection :: Monad m => Full.Selection -> TransformT m (Seq (Selection m))
+selection (Full.FieldSelection field') =
+    maybeToSelectionSet FieldSelection $ field field'
+selection (Full.FragmentSpreadSelection fragmentSpread') =
+    maybeToSelectionSet FragmentSelection $ fragmentSpread fragmentSpread'
+selection (Full.InlineFragmentSelection inlineFragment') =
+   either id (pure . FragmentSelection) <$> inlineFragment inlineFragment'
+
+maybeToSelectionSet :: Monad m
+    => forall a
+    . (a -> Selection m)
+    -> TransformT m (Maybe a)
+    -> TransformT m (Seq (Selection m))
+maybeToSelectionSet selectionType = fmap (maybe Seq.empty $ pure . selectionType)
+
+directives :: Monad m => [Full.Directive] -> TransformT m (Maybe [Type.Directive])
+directives = fmap Type.selection . traverse directive
+
+inlineFragment :: Monad m
+    => Full.InlineFragment
+    -> TransformT m (Either (Seq (Selection m)) (Fragment m))
+inlineFragment (Full.InlineFragment maybeCondition directives' selectionSet' location)
+    | Just typeCondition <- maybeCondition = do
+        transformedSelections <- selectionSet selectionSet'
+        transformedDirectives <- directives directives'
+        maybeFragmentType <- asks
+            $ Type.Internal.lookupTypeCondition typeCondition
+            . types
+        pure $ case transformedDirectives >> maybeFragmentType of
+            Just fragmentType -> Right
+                $ Fragment fragmentType transformedSelections location
+            Nothing -> Left Seq.empty
+    | otherwise = do
+        transformedSelections <- selectionSet selectionSet'
+        transformedDirectives <- directives directives'
+        pure $ if isJust transformedDirectives
+            then Left transformedSelections
+            else Left Seq.empty
+
+fragmentSpread :: Monad m => Full.FragmentSpread -> TransformT m (Maybe (Fragment m))
+fragmentSpread (Full.FragmentSpread spreadName directives' location) = do
+    transformedDirectives <- directives directives'
+    visitedFragment <- asks $ HashSet.member spreadName . visitedFragments
+    possibleFragmentDefinition <- asks
+        $ HashMap.lookup spreadName
+        . fragmentDefinitions
+    case transformedDirectives >> possibleFragmentDefinition of
+        Just (Full.FragmentDefinition _ typeCondition _ selections _)
+            | visitedFragment -> pure Nothing
+            | otherwise -> do
+                fragmentType <- asks
+                    $ Type.Internal.lookupTypeCondition typeCondition
+                    . types
+                traverse (traverseSelections selections) fragmentType
+        Nothing -> pure Nothing
+  where
+    traverseSelections selections typeCondition = do
+        transformedSelections <- TransformT
+            $ local fragmentInserter
+            $ runTransformT
+            $ selectionSet selections
+        pure $ Fragment typeCondition transformedSelections location
+    fragmentInserter replacement@Replacement{ visitedFragments } = replacement
+        { visitedFragments = HashSet.insert spreadName visitedFragments }
+
+field :: Monad m => Full.Field -> TransformT m (Maybe (Field m))
+field (Full.Field alias' name' arguments' directives' selectionSet' location') = do
+    transformedSelections <- selectionSetOpt selectionSet'
+    transformedDirectives <- directives directives'
+    transformedArguments <- arguments arguments'
+    let transformedField = Field
+            alias'
+            name'
+            transformedArguments
+            transformedSelections
+            location'
+    pure $ transformedDirectives >> pure transformedField
+
+arguments :: Monad m => [Full.Argument] -> TransformT m (HashMap Full.Name (Full.Node Input))
+arguments = foldM go HashMap.empty
+  where
+    go accumulator (Full.Argument name' valueNode _) = do
+        argumentValue <- node valueNode
+        pure $ insertIfGiven name' argumentValue accumulator
+
+directive :: Monad m => Full.Directive -> TransformT m Type.Directive
+directive (Full.Directive name' arguments' _)
+    = Type.Directive name'
+    . Type.Arguments
+    <$> foldM go HashMap.empty arguments'
+  where
+    go accumulator (Full.Argument argumentName Full.Node{ node = node' } _) = do
+        transformedValue <- directiveValue node'
+        pure $ HashMap.insert argumentName transformedValue accumulator
+
+directiveValue :: Monad m => Full.Value -> TransformT m Type.Value
+directiveValue = \case
+    (Full.Variable name') -> asks
+        $ HashMap.lookupDefault Type.Null name'
+        . variableValues
+    (Full.Int integer) -> pure $ Type.Int integer
+    (Full.Float double) -> pure $ Type.Float double
+    (Full.String string) -> pure $ Type.String string
+    (Full.Boolean boolean) -> pure $ Type.Boolean boolean
+    Full.Null -> pure Type.Null
+    (Full.Enum enum) -> pure $ Type.Enum enum
+    (Full.List list) -> Type.List <$> traverse directiveNode list
+    (Full.Object objectFields) ->
+        Type.Object <$> foldM objectField HashMap.empty objectFields
+  where
+    directiveNode Full.Node{ node = node'} = directiveValue node'
+    objectField accumulator Full.ObjectField{ name, value } = do
+        transformedValue <- directiveNode value
+        pure $ HashMap.insert name transformedValue accumulator
+
+input :: Monad m => Full.Value -> TransformT m (Maybe Input)
+input (Full.Variable name') =
+    asks (HashMap.lookup name' . variableValues) <&> fmap Variable
+input (Full.Int integer) = pure $ Just $ Int integer
+input (Full.Float double) = pure $ Just $ Float double
+input (Full.String string) = pure $ Just $ String string
+input (Full.Boolean boolean) = pure $ Just $ Boolean boolean
+input Full.Null = pure $ Just Null
+input (Full.Enum enum) = pure $ Just $ Enum enum
+input (Full.List list) = Just . List
+    <$> traverse (fmap (fromMaybe Null) . input . Full.node) list
+input (Full.Object objectFields) = Just . Object
+    <$> foldM objectField HashMap.empty objectFields
+  where
+    objectField accumulator Full.ObjectField{..} = do
+        objectFieldValue <- fmap Full.node <$> node value
+        pure $ insertIfGiven name objectFieldValue accumulator
+
+insertIfGiven :: forall a
+    . Full.Name
+    -> Maybe a
+    -> HashMap Full.Name a
+    -> HashMap Full.Name a
+insertIfGiven name (Just v) = HashMap.insert name v
+insertIfGiven _ _ = id
+
+node :: Monad m => Full.Node Full.Value -> TransformT m (Maybe (Full.Node Input))
+node Full.Node{node = node', ..} =
+    traverse Full.Node <$> input node' <*> pure location
+
+execute :: (MonadCatch m, Coerce.VariableValue a, Coerce.Serialize b)
     => Schema m -- ^ Resolvers.
     -> Maybe Text -- ^ Operation name.
     -> HashMap Full.Name a -- ^ Variable substitution function.
     -> Full.Document -- @GraphQL@ document.
     -> m (Either (ResponseEventStream m b) (Response b))
-execute schema' operationName subs document
-    = either (pure . rightErrorResponse . singleError [] . show) executeRequest
-    $ Transform.document schema' operationName subs document
+execute schema' operationName subs document' =
+    executeRequest schema' document' (Text.unpack <$> operationName) subs
 
-executeRequest :: (MonadCatch m, Serialize a)
-    => Transform.Document m
+executeRequest :: (MonadCatch m, Coerce.Serialize a, Coerce.VariableValue b)
+    => Schema m
+    -> Full.Document
+    -> Maybe String
+    -> HashMap Full.Name b
     -> m (Either (ResponseEventStream m a) (Response a))
-executeRequest (Transform.Document types' rootObjectType operation)
-    | (Transform.Query _ fields objectLocation) <- operation =
-        Right <$> executeOperation types' rootObjectType objectLocation fields
-    | (Transform.Mutation _ fields objectLocation) <- operation =
-        Right <$> executeOperation types' rootObjectType objectLocation fields
-    | (Transform.Subscription _ fields objectLocation) <- operation
-        = either rightErrorResponse Left
-        <$> Subscribe.subscribe types' rootObjectType objectLocation fields
-
--- This is actually executeMutation, but we don't distinguish between queries
--- and mutations yet.
-executeOperation :: (MonadCatch m, Serialize a)
+executeRequest schema sourceDocument operationName variableValues = do
+    operationAndVariables <- sequence buildOperation
+    case operationAndVariables of
+        Left queryError' -> pure
+            $ Right
+            $ Response Coerce.null $ pure $ queryError queryError'
+        Right operation
+            | Operation Full.Query topSelections _operationLocation <- operation ->
+                 Right <$> executeQuery topSelections schema
+            | Operation Full.Mutation topSelections operationLocation <- operation ->
+                Right <$> executeMutation topSelections schema operationLocation
+            | Operation Full.Subscription topSelections operationLocation <- operation ->
+                either rightErrorResponse Left <$> subscribe topSelections schema operationLocation
+  where
+    schemaTypes = Schema.types schema
+    (operationDefinitions, fragmentDefinitions') = document sourceDocument
+    buildOperation = do
+        operationDefinition <- getOperation operationDefinitions operationName
+        coercedVariableValues <- coerceVariableValues
+            schemaTypes
+            operationDefinition
+            variableValues
+        let replacement = Replacement
+                { variableValues = coercedVariableValues
+                , fragmentDefinitions = fragmentDefinitions'
+                , visitedFragments = mempty
+                , types = schemaTypes
+                }
+        pure $ flip runReaderT replacement
+            $ runTransformT
+            $ transform operationDefinition
+
+rightErrorResponse :: Coerce.Serialize b => forall a. Error -> Either a (Response b)
+rightErrorResponse = Right . Response Coerce.null . pure
+
+getOperation :: [Full.OperationDefinition] -> Maybe String -> Either QueryError Full.OperationDefinition
+getOperation [operation] Nothing = Right operation
+getOperation operations (Just givenOperationName)
+    = maybe (Left $ OperationNotFound givenOperationName) Right
+    $ find findOperationByName operations
+  where
+    findOperationByName (Full.OperationDefinition _ (Just operationName) _ _ _ _) =
+        givenOperationName == Text.unpack operationName
+    findOperationByName _ = False
+getOperation _ _ = Left OperationNameRequired
+
+executeQuery :: (MonadCatch m, Coerce.Serialize a)
+    => Seq (Selection m)
+    -> Schema m
+    -> m (Response a)
+executeQuery topSelections schema = do
+    let queryType = Schema.query schema
+    (data', errors) <- runWriterT
+        $ flip runReaderT (Schema.types schema)
+        $ runExecutorT
+        $ executeSelectionSet topSelections queryType Type.Null []
+    pure $ Response data' errors
+
+executeMutation :: (MonadCatch m, Coerce.Serialize a)
+    => Seq (Selection m)
+    -> Schema m
+    -> Full.Location
+    -> m (Response a)
+executeMutation topSelections schema operationLocation
+    | Just mutationType <- Schema.mutation schema = do
+        (data', errors) <- runWriterT
+            $ flip runReaderT (Schema.types schema)
+            $ runExecutorT
+            $ executeSelectionSet topSelections mutationType Type.Null []
+        pure $ Response data' errors
+    | otherwise = pure
+        $ Response Coerce.null
+        $ Seq.singleton
+        $ Error "Schema doesn't support mutations." [operationLocation] []
+
+executeSelectionSet :: (MonadCatch m, Coerce.Serialize a)
+    => Seq (Selection m)
+    -> Out.ObjectType m
+    -> Type.Value
+    -> [Path]
+    -> ExecutorT m a
+executeSelectionSet selections objectType objectValue errorPath = do
+    let groupedFieldSet = collectFields objectType selections
+    resolvedValues <- OrderedMap.traverseMaybe go groupedFieldSet
+    coerceResult (Out.NonNullObjectType objectType) $ Coerce.Object resolvedValues
+  where
+    executeField' fields resolver =
+        executeField objectValue fields resolver errorPath
+    Out.ObjectType _ _ _ resolvers = objectType
+    go fields@(Field _ fieldName _ _ _ :| _) =
+        traverse (executeField' fields) $ HashMap.lookup fieldName resolvers
+
+fieldsSegment :: forall m. NonEmpty (Field m) -> Path
+fieldsSegment (Field alias fieldName _ _ _ :| _) =
+    Segment (fromMaybe fieldName alias)
+
+executeField :: (MonadCatch m, Coerce.Serialize a)
+    => Type.Value
+    -> NonEmpty (Field m)
+    -> Out.Resolver m
+    -> [Path]
+    -> ExecutorT m a
+executeField objectValue fields resolver errorPath =
+    let Field _ fieldName inputArguments _ fieldLocation :| _ = fields
+     in catch (go fieldName inputArguments) $ exceptionHandler fieldLocation
+  where
+    exceptionHandler :: (MonadCatch m, Coerce.Serialize a)
+        => Full.Location
+        -> GraphQLException
+        -> ExecutorT m a
+    exceptionHandler fieldLocation e =
+        let newError = Error (Text.pack $ displayException e) [fieldLocation] errorPath
+         in ExecutorT (lift $ tell $ Seq.singleton newError) >> pure Coerce.null
+    go fieldName inputArguments = do
+        let (Out.Field _ fieldType argumentTypes, resolveFunction) =
+                resolverField resolver
+        argumentValues <- coerceArgumentValues argumentTypes inputArguments
+        resolvedValue <-
+            resolveFieldValue resolveFunction objectValue fieldName argumentValues
+        completeValue fieldType fields errorPath resolvedValue
+    resolverField (Out.ValueResolver resolverField' resolveFunction) =
+        (resolverField', resolveFunction)
+    resolverField (Out.EventStreamResolver resolverField' resolveFunction _) =
+        (resolverField', resolveFunction)
+
+resolveFieldValue :: MonadCatch m
+    => Out.Resolve m
+    -> Type.Value
+    -> Full.Name
+    -> Type.Subs
+    -> ExecutorT m Type.Value
+resolveFieldValue resolver objectValue _fieldName argumentValues =
+    lift $ runReaderT resolver context
+  where
+    context = Type.Context
+        { Type.arguments = Type.Arguments argumentValues
+        , Type.values = objectValue
+        }
+
+resolveAbstractType :: Monad m
+    => Type.Internal.AbstractType m
+    -> Type.Subs
+    -> ExecutorT m (Maybe (Out.ObjectType m))
+resolveAbstractType abstractType values'
+    | Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do
+        types' <- ExecutorT ask
+        case HashMap.lookup typeName types' of
+            Just (Type.Internal.ObjectType objectType) ->
+                if Type.Internal.instanceOf objectType abstractType
+                    then pure $ Just objectType
+                    else pure Nothing
+            _ -> pure Nothing
+    | otherwise = pure Nothing
+
+completeValue :: (MonadCatch m, Coerce.Serialize a)
+    => Out.Type m
+    -> NonEmpty (Field m)
+    -> [Path]
+    -> Type.Value
+    -> ExecutorT m a
+completeValue outputType _ _ Type.Null
+    | Out.isNonNullType outputType = throwFieldError NullResultError
+    | otherwise = pure Coerce.null
+completeValue outputType@(Out.ListBaseType listType) fields errorPath (Type.List list)
+    = foldM go (0, []) list >>= coerceResult outputType . Coerce.List . snd
+  where
+    go (index, accumulator) listItem = do
+        let updatedPath = Index index : errorPath
+        completedValue <- completeValue listType fields updatedPath listItem
+        pure (index + 1, completedValue : accumulator)
+completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Int int) =
+    coerceResult outputType $ Coerce.Int int
+completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Boolean boolean) =
+    coerceResult outputType $ Coerce.Boolean boolean
+completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Float float) =
+    coerceResult outputType $ Coerce.Float float
+completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.String string) =
+    coerceResult outputType $ Coerce.String string
+completeValue outputType@(Out.EnumBaseType enumType) _ _ (Type.Enum enum) =
+    let Type.EnumType _ _ enumMembers = enumType
+     in if HashMap.member enum enumMembers
+        then coerceResult outputType $ Coerce.Enum enum
+        else throwM
+            $ ValueCompletionException (show outputType)
+            $ Type.Enum enum
+completeValue (Out.ObjectBaseType objectType) fields errorPath result
+    = executeSelectionSet (mergeSelectionSets fields) objectType result
+    $ fieldsSegment fields : errorPath
+completeValue outputType@(Out.InterfaceBaseType interfaceType) fields errorPath result
+    | Type.Object objectMap <- result = do
+        let abstractType = Type.Internal.AbstractInterfaceType interfaceType
+        concreteType <- resolveAbstractType abstractType objectMap
+        case concreteType of
+            Just objectType
+                -> executeSelectionSet (mergeSelectionSets fields) objectType result
+                $ fieldsSegment fields : errorPath
+            Nothing -> throwM
+                $ ValueCompletionException (show outputType) result
+completeValue outputType@(Out.UnionBaseType unionType) fields errorPath result
+    | Type.Object objectMap <- result = do
+        let abstractType = Type.Internal.AbstractUnionType unionType
+        concreteType <- resolveAbstractType abstractType objectMap
+        case concreteType of
+            Just objectType
+                -> executeSelectionSet (mergeSelectionSets fields) objectType result
+                $ fieldsSegment fields : errorPath
+            Nothing -> throwM
+                $ ValueCompletionException (show outputType) result
+completeValue outputType _ _ result =
+    throwM $ ValueCompletionException (show outputType) result
+
+coerceResult :: (MonadCatch m, Coerce.Serialize a)
+    => Out.Type m
+    -> Coerce.Output a
+    -> ExecutorT m a
+coerceResult outputType result
+    | Just serialized <- Coerce.serialize outputType result = pure serialized
+    | otherwise = throwFieldError ResultCoercionError
+
+mergeSelectionSets :: MonadCatch m
+    => NonEmpty (Field m)
+    -> Seq (Selection m)
+mergeSelectionSets = foldr forEach mempty
+  where
+    forEach (Field _ _ _ fieldSelectionSet _) selectionSet' =
+        selectionSet' <> fieldSelectionSet
+
+throwFieldError :: MonadCatch m => FieldError -> m a
+throwFieldError = throwM . FieldException
+
+coerceArgumentValues :: MonadCatch m
+    => HashMap Full.Name In.Argument
+    -> HashMap Full.Name (Full.Node Input)
+    -> m Type.Subs
+coerceArgumentValues argumentDefinitions argumentValues =
+    HashMap.foldrWithKey c pure argumentDefinitions mempty
+  where
+    c argumentName argumentType pure' resultMap =
+        forEach argumentName argumentType resultMap >>= pure'
+    forEach :: MonadCatch m
+         => Full.Name
+         -> In.Argument
+         -> Type.Subs
+         -> m Type.Subs
+    forEach argumentName (In.Argument _ variableType defaultValue) resultMap = do
+        let matchedMap
+                = matchFieldValues' argumentName variableType defaultValue
+                $ Just resultMap
+         in case matchedMap of
+            Just matchedValues -> pure matchedValues
+            Nothing
+                | Just _ <- HashMap.lookup argumentName argumentValues ->
+                    throwFieldError ArgumentTypeError
+                | otherwise -> throwFieldError MissingArgumentError
+    matchFieldValues' = Coerce.matchFieldValues coerceArgumentValue
+        $ Full.node <$> argumentValues
+    coerceArgumentValue inputType (Int integer) =
+        Coerce.coerceInputLiteral inputType (Type.Int integer)
+    coerceArgumentValue inputType (Boolean boolean) =
+        Coerce.coerceInputLiteral inputType (Type.Boolean boolean)
+    coerceArgumentValue inputType (String string) =
+        Coerce.coerceInputLiteral inputType (Type.String string)
+    coerceArgumentValue inputType (Float float) =
+        Coerce.coerceInputLiteral inputType (Type.Float float)
+    coerceArgumentValue inputType (Enum enum) =
+        Coerce.coerceInputLiteral inputType (Type.Enum enum)
+    coerceArgumentValue inputType Null
+        | In.isNonNullType inputType = Nothing
+        | otherwise = Coerce.coerceInputLiteral inputType Type.Null
+    coerceArgumentValue (In.ListBaseType inputType) (List list) =
+        let coerceItem = coerceArgumentValue inputType
+         in Type.List <$> traverse coerceItem list
+    coerceArgumentValue (In.InputObjectBaseType inputType) (Object object)
+        | In.InputObjectType _ _ inputFields <- inputType = 
+            let go = forEachField object
+                resultMap = HashMap.foldrWithKey go (pure mempty) inputFields
+             in Type.Object <$> resultMap
+    coerceArgumentValue _ (Variable variable) = pure variable
+    coerceArgumentValue _ _ = Nothing
+    forEachField object variableName (In.InputField _ variableType defaultValue) =
+        Coerce.matchFieldValues coerceArgumentValue object variableName variableType defaultValue
+
+collectFields :: Monad m
+    => Out.ObjectType m
+    -> Seq (Selection m)
+    -> OrderedMap (NonEmpty (Field m))
+collectFields objectType = foldl forEach OrderedMap.empty
+  where
+    forEach groupedFields (FieldSelection fieldSelection) =
+        let Field maybeAlias fieldName _ _ _ = fieldSelection
+            responseKey = fromMaybe fieldName maybeAlias
+         in OrderedMap.insert responseKey (fieldSelection :| []) groupedFields
+    forEach groupedFields (FragmentSelection selectionFragment)
+        | Fragment fragmentType fragmentSelectionSet _ <- selectionFragment
+        , Type.Internal.doesFragmentTypeApply fragmentType objectType =
+            let fragmentGroupedFieldSet =
+                    collectFields objectType fragmentSelectionSet
+             in groupedFields <> fragmentGroupedFieldSet
+        | otherwise = groupedFields
+
+coerceVariableValues :: (Monad m, Coerce.VariableValue b)
+    => HashMap Full.Name (Schema.Type m)
+    -> Full.OperationDefinition
+    -> HashMap Full.Name b
+    -> Either QueryError Type.Subs
+coerceVariableValues types operationDefinition' variableValues
+    | Full.OperationDefinition _ _ variableDefinitions _ _ _ <-
+        operationDefinition'
+    = foldr forEach (Right HashMap.empty) variableDefinitions
+    | otherwise = pure mempty
+  where
+    forEach variableDefinition (Right coercedValues) =
+        let Full.VariableDefinition variableName variableTypeName defaultValue _ =
+                variableDefinition
+            defaultValue' = constValue . Full.node <$> defaultValue
+         in case Type.Internal.lookupInputType variableTypeName types of
+            Just variableType ->
+                maybe (Left $ CoercionError variableDefinition) Right
+                    $ Coerce.matchFieldValues
+                        coerceVariableValue'
+                        variableValues
+                        variableName
+                        variableType
+                        defaultValue'
+                    $ Just coercedValues
+            Nothing -> Left $ UnknownInputType variableDefinition
+    forEach _ coercedValuesOrError = coercedValuesOrError
+    coerceVariableValue' variableType value'
+        = Coerce.coerceVariableValue variableType value'
+        >>= Coerce.coerceInputLiteral variableType
+
+constValue :: Full.ConstValue -> Type.Value
+constValue (Full.ConstInt i) = Type.Int i
+constValue (Full.ConstFloat f) = Type.Float f
+constValue (Full.ConstString x) = Type.String x
+constValue (Full.ConstBoolean b) = Type.Boolean b
+constValue Full.ConstNull = Type.Null
+constValue (Full.ConstEnum e) = Type.Enum e
+constValue (Full.ConstList list) = Type.List $ constValue . Full.node <$> list
+constValue (Full.ConstObject o) =
+    Type.Object $ HashMap.fromList $ constObjectField <$> o
+  where
+    constObjectField Full.ObjectField{value = value', ..} =
+        (name, constValue $ Full.node value')
+
+subscribe :: (MonadCatch m, Coerce.Serialize a)
+    => Seq (Selection m)
+    -> Schema m
+    -> Full.Location
+    -> m (Either Error (ResponseEventStream m a))
+subscribe fields schema objectLocation
+    | Just objectType <- Schema.subscription schema = do
+        let types' = Schema.types schema
+        sourceStream <-
+            createSourceEventStream types' objectType objectLocation fields
+        let traverser =
+                mapSourceToResponseEvent types' objectType fields
+        traverse traverser sourceStream
+    | otherwise = pure $ Left
+        $ Error "Schema doesn't support subscriptions." [] []
+
+mapSourceToResponseEvent :: (MonadCatch m, Coerce.Serialize a)
+    => HashMap Full.Name (Type m)
+    -> Out.ObjectType m
+    -> Seq (Selection m)
+    -> Out.SourceEventStream m
+    -> m (ResponseEventStream m a)
+mapSourceToResponseEvent types' subscriptionType fields sourceStream
+    = pure
+    $ sourceStream
+    .| mapMC (executeSubscriptionEvent types' subscriptionType fields)
+
+createSourceEventStream :: MonadCatch m
     => HashMap Full.Name (Type m)
     -> Out.ObjectType m
     -> Full.Location
-    -> Seq (Transform.Selection m)
-    -> m (Response a)
-executeOperation types' objectType objectLocation fields
-    = runCollectErrs types'
-    $ executeSelectionSet Definition.Null objectType objectLocation fields
+    -> Seq (Selection m)
+    -> m (Either Error (Out.SourceEventStream m))
+createSourceEventStream _types subscriptionType objectLocation fields
+    | [fieldGroup] <- OrderedMap.elems groupedFieldSet
+    , Field _ fieldName arguments' _ errorLocation <- NonEmpty.head fieldGroup
+    , Out.ObjectType _ _ _ fieldTypes <- subscriptionType
+    , resolverT <- fieldTypes HashMap.! fieldName
+    , Out.EventStreamResolver fieldDefinition _ resolver <- resolverT
+    , Out.Field _ _fieldType argumentDefinitions <- fieldDefinition =
+        case coerceArgumentValues argumentDefinitions arguments' of
+            Left _ -> pure
+                $ Left
+                $ Error "Argument coercion failed." [errorLocation] []
+            Right  argumentValues -> left (singleError' [errorLocation])
+                <$> resolveFieldEventStream Type.Null argumentValues resolver
+    | otherwise = pure
+        $ Left
+        $ Error "Subscription contains more than one field." [objectLocation] []
+  where
+    groupedFieldSet = collectFields subscriptionType fields
 
-rightErrorResponse :: Serialize b => forall a. Error -> Either a (Response b)
-rightErrorResponse = Right . Response null . pure
+singleError' :: [Full.Location] -> String -> Error
+singleError' errorLocations message = Error (Text.pack message) errorLocations []
+
+resolveFieldEventStream :: MonadCatch m
+    => Type.Value
+    -> Type.Subs
+    -> Out.Subscribe m
+    -> m (Either String (Out.SourceEventStream m))
+resolveFieldEventStream result args resolver =
+    catch (Right <$> runReaderT resolver context) handleEventStreamError
+  where
+    handleEventStreamError :: MonadCatch m
+        => ResolverException
+        -> m (Either String (Out.SourceEventStream m))
+    handleEventStreamError = pure . Left . displayException
+    context = Type.Context
+        { Type.arguments = Type.Arguments args
+        , Type.values = result
+        }
+
+executeSubscriptionEvent :: (MonadCatch m, Coerce.Serialize a)
+    => HashMap Full.Name (Type m)
+    -> Out.ObjectType m
+    -> Seq (Selection m)
+    -> Type.Value
+    -> m (Response a)
+executeSubscriptionEvent types' objectType fields initialValue = do
+    (data', errors) <- runWriterT
+        $ flip runReaderT types'
+        $ runExecutorT
+        $ executeSelectionSet fields objectType initialValue []
+    pure $ Response data' errors