{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}

module Language.GraphQL.Execute.Execution
    ( coerceArgumentValues
    , collectFields
    , executeSelectionSet
    ) where

import Control.Monad.Catch (Exception(..), MonadCatch(..))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (runReaderT)
import Control.Monad.Trans.State (gets)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (fromMaybe)
import Data.Sequence (Seq(..))
import qualified Data.Text as Text
import qualified Language.GraphQL.AST as Full
import Language.GraphQL.Error
import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Execute.Internal
import Language.GraphQL.Execute.OrderedMap (OrderedMap)
import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
import qualified Language.GraphQL.Execute.Transform as Transform
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
import qualified Language.GraphQL.Type.Internal as Internal
import Prelude hiding (null)

resolveFieldValue :: MonadCatch m
    => Type.Value
    -> Type.Subs
    -> Type.Resolve m
    -> Full.Location
    -> CollectErrsT m Type.Value
resolveFieldValue :: Value -> Subs -> Resolve m -> Location -> CollectErrsT m Value
resolveFieldValue Value
result Subs
args Resolve m
resolver Location
location' =
    CollectErrsT m Value
-> (ResolverException -> CollectErrsT m Value)
-> CollectErrsT m Value
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (m Value -> CollectErrsT m Value
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Value -> CollectErrsT m Value)
-> m Value -> CollectErrsT m Value
forall a b. (a -> b) -> a -> b
$ Resolve m -> Context -> m Value
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Resolve m
resolver Context
context) ResolverException -> CollectErrsT m Value
forall (m :: * -> *).
MonadCatch m =>
ResolverException -> CollectErrsT m Value
handleFieldError
  where
    handleFieldError :: MonadCatch m
        => ResolverException
        -> CollectErrsT m Type.Value
    handleFieldError :: ResolverException -> CollectErrsT m Value
handleFieldError ResolverException
e
        = Value -> Error -> CollectErrsT m Value
forall (m :: * -> *) a.
MonadCatch m =>
a -> Error -> CollectErrsT m a
addError Value
Type.Null
        (Error -> CollectErrsT m Value) -> Error -> CollectErrsT m Value
forall a b. (a -> b) -> a -> b
$ Text -> [Location] -> [Path] -> Error
Error (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ResolverException -> String
forall e. Exception e => e -> String
displayException ResolverException
e) [Location
location'] []
    context :: Context
context = Context :: Arguments -> Value -> Context
Type.Context
        { arguments :: Arguments
Type.arguments = Subs -> Arguments
Type.Arguments Subs
args
        , values :: Value
Type.values = Value
result
        }

collectFields :: Monad m
    => Out.ObjectType m
    -> Seq (Transform.Selection m)
    -> OrderedMap (NonEmpty (Transform.Field m))
collectFields :: ObjectType m
-> Seq (Selection m) -> OrderedMap (NonEmpty (Field m))
collectFields ObjectType m
objectType = (OrderedMap (NonEmpty (Field m))
 -> Selection m -> OrderedMap (NonEmpty (Field m)))
-> OrderedMap (NonEmpty (Field m))
-> Seq (Selection m)
-> OrderedMap (NonEmpty (Field m))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl OrderedMap (NonEmpty (Field m))
-> Selection m -> OrderedMap (NonEmpty (Field m))
forEach OrderedMap (NonEmpty (Field m))
forall v. OrderedMap v
OrderedMap.empty
  where
    forEach :: OrderedMap (NonEmpty (Field m))
-> Selection m -> OrderedMap (NonEmpty (Field m))
forEach OrderedMap (NonEmpty (Field m))
groupedFields (Transform.SelectionField Field m
field) =
        let responseKey :: Text
responseKey = Field m -> Text
forall (m :: * -> *). Field m -> Text
aliasOrName Field m
field
         in Text
-> NonEmpty (Field m)
-> OrderedMap (NonEmpty (Field m))
-> OrderedMap (NonEmpty (Field m))
forall v. Semigroup v => Text -> v -> OrderedMap v -> OrderedMap v
OrderedMap.insert Text
responseKey (Field m
field Field m -> [Field m] -> NonEmpty (Field m)
forall a. a -> [a] -> NonEmpty a
:| []) OrderedMap (NonEmpty (Field m))
groupedFields
    forEach OrderedMap (NonEmpty (Field m))
groupedFields (Transform.SelectionFragment Fragment m
selectionFragment)
        | Transform.Fragment CompositeType m
fragmentType Seq (Selection m)
fragmentSelectionSet <- Fragment m
selectionFragment
        , CompositeType m -> ObjectType m -> Bool
forall (m :: * -> *). CompositeType m -> ObjectType m -> Bool
Internal.doesFragmentTypeApply CompositeType m
fragmentType ObjectType m
objectType =
            let fragmentGroupedFieldSet :: OrderedMap (NonEmpty (Field m))
fragmentGroupedFieldSet = ObjectType m
-> Seq (Selection m) -> OrderedMap (NonEmpty (Field m))
forall (m :: * -> *).
Monad m =>
ObjectType m
-> Seq (Selection m) -> OrderedMap (NonEmpty (Field m))
collectFields ObjectType m
objectType Seq (Selection m)
fragmentSelectionSet
             in OrderedMap (NonEmpty (Field m))
groupedFields OrderedMap (NonEmpty (Field m))
-> OrderedMap (NonEmpty (Field m))
-> OrderedMap (NonEmpty (Field m))
forall a. Semigroup a => a -> a -> a
<> OrderedMap (NonEmpty (Field m))
fragmentGroupedFieldSet
        | Bool
otherwise = OrderedMap (NonEmpty (Field m))
groupedFields

aliasOrName :: forall m. Transform.Field m -> Full.Name
aliasOrName :: Field m -> Text
aliasOrName (Transform.Field Maybe Text
alias Text
name HashMap Text (Node Input)
_ Seq (Selection m)
_ Location
_) = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
name Maybe Text
alias

resolveAbstractType :: Monad m
    => Internal.AbstractType m
    -> Type.Subs
    -> CollectErrsT m (Maybe (Out.ObjectType m))
resolveAbstractType :: AbstractType m -> Subs -> CollectErrsT m (Maybe (ObjectType m))
resolveAbstractType AbstractType m
abstractType Subs
values'
    | Just (Type.String Text
typeName) <- Text -> Subs -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
"__typename" Subs
values' = do
        HashMap Text (Type m)
types' <- (Resolution m -> HashMap Text (Type m))
-> StateT (Resolution m) m (HashMap Text (Type m))
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets Resolution m -> HashMap Text (Type m)
forall (m :: * -> *). Resolution m -> HashMap Text (Type m)
types
        case Text -> HashMap Text (Type m) -> Maybe (Type m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
typeName HashMap Text (Type m)
types' of
            Just (Internal.ObjectType ObjectType m
objectType) ->
                if ObjectType m -> AbstractType m -> Bool
forall (m :: * -> *). ObjectType m -> AbstractType m -> Bool
Internal.instanceOf ObjectType m
objectType AbstractType m
abstractType
                    then Maybe (ObjectType m) -> CollectErrsT m (Maybe (ObjectType m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (ObjectType m) -> CollectErrsT m (Maybe (ObjectType m)))
-> Maybe (ObjectType m) -> CollectErrsT m (Maybe (ObjectType m))
forall a b. (a -> b) -> a -> b
$ ObjectType m -> Maybe (ObjectType m)
forall a. a -> Maybe a
Just ObjectType m
objectType
                    else Maybe (ObjectType m) -> CollectErrsT m (Maybe (ObjectType m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ObjectType m)
forall a. Maybe a
Nothing
            Maybe (Type m)
_ -> Maybe (ObjectType m) -> CollectErrsT m (Maybe (ObjectType m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ObjectType m)
forall a. Maybe a
Nothing
    | Bool
otherwise = Maybe (ObjectType m) -> CollectErrsT m (Maybe (ObjectType m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ObjectType m)
forall a. Maybe a
Nothing

executeField :: (MonadCatch m, Serialize a)
    => Out.Resolver m
    -> Type.Value
    -> NonEmpty (Transform.Field m)
    -> CollectErrsT m a
executeField :: Resolver m -> Value -> NonEmpty (Field m) -> CollectErrsT m a
executeField Resolver m
fieldResolver Value
prev NonEmpty (Field m)
fields
    | Out.ValueResolver Field m
fieldDefinition Resolve m
resolver <- Resolver m
fieldResolver =
        Field m -> Resolve m -> CollectErrsT m a
forall a. Serialize a => Field m -> Resolve m -> CollectErrsT m a
executeField' Field m
fieldDefinition Resolve m
resolver
    | Out.EventStreamResolver Field m
fieldDefinition Resolve m
resolver Subscribe m
_ <- Resolver m
fieldResolver =
        Field m -> Resolve m -> CollectErrsT m a
forall a. Serialize a => Field m -> Resolve m -> CollectErrsT m a
executeField' Field m
fieldDefinition Resolve m
resolver
  where
    executeField' :: Field m -> Resolve m -> CollectErrsT m a
executeField' Field m
fieldDefinition Resolve m
resolver = do
        let Out.Field Maybe Text
_ Type m
fieldType Arguments
argumentDefinitions = Field m
fieldDefinition
        let Transform.Field Maybe Text
_ Text
_ HashMap Text (Node Input)
arguments' Seq (Selection m)
_ Location
location' = NonEmpty (Field m) -> Field m
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty (Field m)
fields
        case Arguments -> HashMap Text (Node Input) -> Either [Location] Subs
coerceArgumentValues Arguments
argumentDefinitions HashMap Text (Node Input)
arguments' of
            Left [] ->
                let errorMessage :: Text
errorMessage = Text
"Not all required arguments are specified."
                 in a -> Error -> CollectErrsT m a
forall (m :: * -> *) a.
MonadCatch m =>
a -> Error -> CollectErrsT m a
addError a
forall a. Serialize a => a
null (Error -> CollectErrsT m a) -> Error -> CollectErrsT m a
forall a b. (a -> b) -> a -> b
$ Text -> [Location] -> [Path] -> Error
Error Text
errorMessage [Location
location'] []
            Left [Location]
errorLocations -> a -> Error -> CollectErrsT m a
forall (m :: * -> *) a.
MonadCatch m =>
a -> Error -> CollectErrsT m a
addError a
forall a. Serialize a => a
null
                (Error -> CollectErrsT m a) -> Error -> CollectErrsT m a
forall a b. (a -> b) -> a -> b
$ Text -> [Location] -> [Path] -> Error
Error Text
"Argument coercing failed." [Location]
errorLocations []
            Right Subs
argumentValues -> do
                Value
answer <- Value -> Subs -> Resolve m -> Location -> CollectErrsT m Value
forall (m :: * -> *).
MonadCatch m =>
Value -> Subs -> Resolve m -> Location -> CollectErrsT m Value
resolveFieldValue Value
prev Subs
argumentValues Resolve m
resolver Location
location'
                Type m -> NonEmpty (Field m) -> Value -> CollectErrsT m a
forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Type m -> NonEmpty (Field m) -> Value -> CollectErrsT m a
completeValue Type m
fieldType NonEmpty (Field m)
fields Value
answer

completeValue :: (MonadCatch m, Serialize a)
    => Out.Type m
    -> NonEmpty (Transform.Field m)
    -> Type.Value
    -> CollectErrsT m a
completeValue :: Type m -> NonEmpty (Field m) -> Value -> CollectErrsT m a
completeValue (Type m -> Bool
forall (m :: * -> *). Type m -> Bool
Out.isNonNullType -> Bool
False) NonEmpty (Field m)
_ Value
Type.Null = a -> CollectErrsT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Serialize a => a
null
completeValue outputType :: Type m
outputType@(Out.ListBaseType Type m
listType) NonEmpty (Field m)
fields (Type.List [Value]
list)
    = (Value -> CollectErrsT m a)
-> [Value] -> StateT (Resolution m) m [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Type m -> NonEmpty (Field m) -> Value -> CollectErrsT m a
forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Type m -> NonEmpty (Field m) -> Value -> CollectErrsT m a
completeValue Type m
listType NonEmpty (Field m)
fields) [Value]
list
    StateT (Resolution m) m [a]
-> ([a] -> CollectErrsT m a) -> CollectErrsT m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type m -> Location -> Output a -> CollectErrsT m a
forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Type m -> Location -> Output a -> CollectErrsT m a
coerceResult Type m
outputType (NonEmpty (Field m) -> Location
forall (m :: * -> *).
MonadCatch m =>
NonEmpty (Field m) -> Location
firstFieldLocation NonEmpty (Field m)
fields) (Output a -> CollectErrsT m a)
-> ([a] -> Output a) -> [a] -> CollectErrsT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Output a
forall a. [a] -> Output a
List
completeValue outputType :: Type m
outputType@(Out.ScalarBaseType ScalarType
_) NonEmpty (Field m)
fields (Type.Int Int32
int) =
    Type m -> Location -> Output a -> CollectErrsT m a
forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Type m -> Location -> Output a -> CollectErrsT m a
coerceResult Type m
outputType (NonEmpty (Field m) -> Location
forall (m :: * -> *).
MonadCatch m =>
NonEmpty (Field m) -> Location
firstFieldLocation NonEmpty (Field m)
fields) (Output a -> CollectErrsT m a) -> Output a -> CollectErrsT m a
forall a b. (a -> b) -> a -> b
$ Int32 -> Output a
forall a. Int32 -> Output a
Int Int32
int
completeValue outputType :: Type m
outputType@(Out.ScalarBaseType ScalarType
_) NonEmpty (Field m)
fields (Type.Boolean Bool
boolean) =
    Type m -> Location -> Output a -> CollectErrsT m a
forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Type m -> Location -> Output a -> CollectErrsT m a
coerceResult Type m
outputType (NonEmpty (Field m) -> Location
forall (m :: * -> *).
MonadCatch m =>
NonEmpty (Field m) -> Location
firstFieldLocation NonEmpty (Field m)
fields) (Output a -> CollectErrsT m a) -> Output a -> CollectErrsT m a
forall a b. (a -> b) -> a -> b
$ Bool -> Output a
forall a. Bool -> Output a
Boolean Bool
boolean
completeValue outputType :: Type m
outputType@(Out.ScalarBaseType ScalarType
_) NonEmpty (Field m)
fields (Type.Float Double
float) =
    Type m -> Location -> Output a -> CollectErrsT m a
forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Type m -> Location -> Output a -> CollectErrsT m a
coerceResult Type m
outputType (NonEmpty (Field m) -> Location
forall (m :: * -> *).
MonadCatch m =>
NonEmpty (Field m) -> Location
firstFieldLocation NonEmpty (Field m)
fields) (Output a -> CollectErrsT m a) -> Output a -> CollectErrsT m a
forall a b. (a -> b) -> a -> b
$ Double -> Output a
forall a. Double -> Output a
Float Double
float
completeValue outputType :: Type m
outputType@(Out.ScalarBaseType ScalarType
_) NonEmpty (Field m)
fields (Type.String Text
string) =
    Type m -> Location -> Output a -> CollectErrsT m a
forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Type m -> Location -> Output a -> CollectErrsT m a
coerceResult Type m
outputType (NonEmpty (Field m) -> Location
forall (m :: * -> *).
MonadCatch m =>
NonEmpty (Field m) -> Location
firstFieldLocation NonEmpty (Field m)
fields) (Output a -> CollectErrsT m a) -> Output a -> CollectErrsT m a
forall a b. (a -> b) -> a -> b
$ Text -> Output a
forall a. Text -> Output a
String Text
string
completeValue outputType :: Type m
outputType@(Out.EnumBaseType EnumType
enumType) NonEmpty (Field m)
fields (Type.Enum Text
enum) =
    let Type.EnumType Text
_ Maybe Text
_ HashMap Text EnumValue
enumMembers = EnumType
enumType
        location :: Location
location = NonEmpty (Field m) -> Location
forall (m :: * -> *).
MonadCatch m =>
NonEmpty (Field m) -> Location
firstFieldLocation NonEmpty (Field m)
fields
     in if Text -> HashMap Text EnumValue -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HashMap.member Text
enum HashMap Text EnumValue
enumMembers
        then Type m -> Location -> Output a -> CollectErrsT m a
forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Type m -> Location -> Output a -> CollectErrsT m a
coerceResult Type m
outputType Location
location (Output a -> CollectErrsT m a) -> Output a -> CollectErrsT m a
forall a b. (a -> b) -> a -> b
$ Text -> Output a
forall a. Text -> Output a
Enum Text
enum
        else a -> Error -> CollectErrsT m a
forall (m :: * -> *) a.
MonadCatch m =>
a -> Error -> CollectErrsT m a
addError a
forall a. Serialize a => a
null (Error -> CollectErrsT m a) -> Error -> CollectErrsT m a
forall a b. (a -> b) -> a -> b
$ Text -> [Location] -> [Path] -> Error
Error Text
"Enum value completion failed." [Location
location] []
completeValue (Out.ObjectBaseType ObjectType m
objectType) NonEmpty (Field m)
fields Value
result
    = Value
-> ObjectType m
-> Location
-> Seq (Selection m)
-> CollectErrsT m a
forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Value
-> ObjectType m
-> Location
-> Seq (Selection m)
-> CollectErrsT m a
executeSelectionSet Value
result ObjectType m
objectType (NonEmpty (Field m) -> Location
forall (m :: * -> *).
MonadCatch m =>
NonEmpty (Field m) -> Location
firstFieldLocation NonEmpty (Field m)
fields)
    (Seq (Selection m) -> CollectErrsT m a)
-> Seq (Selection m) -> CollectErrsT m a
forall a b. (a -> b) -> a -> b
$ NonEmpty (Field m) -> Seq (Selection m)
forall (m :: * -> *).
MonadCatch m =>
NonEmpty (Field m) -> Seq (Selection m)
mergeSelectionSets NonEmpty (Field m)
fields
completeValue (Out.InterfaceBaseType InterfaceType m
interfaceType) NonEmpty (Field m)
fields Value
result
    | Type.Object Subs
objectMap <- Value
result = do
        let abstractType :: AbstractType m
abstractType = InterfaceType m -> AbstractType m
forall (m :: * -> *). InterfaceType m -> AbstractType m
Internal.AbstractInterfaceType InterfaceType m
interfaceType
        let location :: Location
location = NonEmpty (Field m) -> Location
forall (m :: * -> *).
MonadCatch m =>
NonEmpty (Field m) -> Location
firstFieldLocation NonEmpty (Field m)
fields
        Maybe (ObjectType m)
concreteType <- AbstractType m -> Subs -> CollectErrsT m (Maybe (ObjectType m))
forall (m :: * -> *).
Monad m =>
AbstractType m -> Subs -> CollectErrsT m (Maybe (ObjectType m))
resolveAbstractType AbstractType m
abstractType Subs
objectMap
        case Maybe (ObjectType m)
concreteType of
            Just ObjectType m
objectType -> Value
-> ObjectType m
-> Location
-> Seq (Selection m)
-> CollectErrsT m a
forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Value
-> ObjectType m
-> Location
-> Seq (Selection m)
-> CollectErrsT m a
executeSelectionSet Value
result ObjectType m
objectType Location
location
                (Seq (Selection m) -> CollectErrsT m a)
-> Seq (Selection m) -> CollectErrsT m a
forall a b. (a -> b) -> a -> b
$ NonEmpty (Field m) -> Seq (Selection m)
forall (m :: * -> *).
MonadCatch m =>
NonEmpty (Field m) -> Seq (Selection m)
mergeSelectionSets NonEmpty (Field m)
fields
            Maybe (ObjectType m)
Nothing -> a -> Error -> CollectErrsT m a
forall (m :: * -> *) a.
MonadCatch m =>
a -> Error -> CollectErrsT m a
addError a
forall a. Serialize a => a
null
                (Error -> CollectErrsT m a) -> Error -> CollectErrsT m a
forall a b. (a -> b) -> a -> b
$ Text -> [Location] -> [Path] -> Error
Error Text
"Interface value completion failed." [Location
location] []
completeValue (Out.UnionBaseType UnionType m
unionType) NonEmpty (Field m)
fields Value
result
    | Type.Object Subs
objectMap <- Value
result = do
        let abstractType :: AbstractType m
abstractType = UnionType m -> AbstractType m
forall (m :: * -> *). UnionType m -> AbstractType m
Internal.AbstractUnionType UnionType m
unionType
        let  location :: Location
location = NonEmpty (Field m) -> Location
forall (m :: * -> *).
MonadCatch m =>
NonEmpty (Field m) -> Location
firstFieldLocation NonEmpty (Field m)
fields
        Maybe (ObjectType m)
concreteType <- AbstractType m -> Subs -> CollectErrsT m (Maybe (ObjectType m))
forall (m :: * -> *).
Monad m =>
AbstractType m -> Subs -> CollectErrsT m (Maybe (ObjectType m))
resolveAbstractType AbstractType m
abstractType Subs
objectMap
        case Maybe (ObjectType m)
concreteType of
            Just ObjectType m
objectType -> Value
-> ObjectType m
-> Location
-> Seq (Selection m)
-> CollectErrsT m a
forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Value
-> ObjectType m
-> Location
-> Seq (Selection m)
-> CollectErrsT m a
executeSelectionSet Value
result ObjectType m
objectType
                Location
location (Seq (Selection m) -> CollectErrsT m a)
-> Seq (Selection m) -> CollectErrsT m a
forall a b. (a -> b) -> a -> b
$ NonEmpty (Field m) -> Seq (Selection m)
forall (m :: * -> *).
MonadCatch m =>
NonEmpty (Field m) -> Seq (Selection m)
mergeSelectionSets NonEmpty (Field m)
fields
            Maybe (ObjectType m)
Nothing -> a -> Error -> CollectErrsT m a
forall (m :: * -> *) a.
MonadCatch m =>
a -> Error -> CollectErrsT m a
addError a
forall a. Serialize a => a
null
                (Error -> CollectErrsT m a) -> Error -> CollectErrsT m a
forall a b. (a -> b) -> a -> b
$ Text -> [Location] -> [Path] -> Error
Error Text
"Union value completion failed." [Location
location] []
completeValue Type m
_ (Transform.Field Maybe Text
_ Text
_ HashMap Text (Node Input)
_ Seq (Selection m)
_ Location
location :| [Field m]
_) Value
_ =
    a -> Error -> CollectErrsT m a
forall (m :: * -> *) a.
MonadCatch m =>
a -> Error -> CollectErrsT m a
addError a
forall a. Serialize a => a
null (Error -> CollectErrsT m a) -> Error -> CollectErrsT m a
forall a b. (a -> b) -> a -> b
$ Text -> [Location] -> [Path] -> Error
Error Text
"Value completion failed." [Location
location] []

mergeSelectionSets :: MonadCatch m
    => NonEmpty (Transform.Field m)
    -> Seq (Transform.Selection m)
mergeSelectionSets :: NonEmpty (Field m) -> Seq (Selection m)
mergeSelectionSets = (Field m -> Seq (Selection m) -> Seq (Selection m))
-> Seq (Selection m) -> NonEmpty (Field m) -> Seq (Selection m)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Field m -> Seq (Selection m) -> Seq (Selection m)
forall (m :: * -> *).
Field m -> Seq (Selection m) -> Seq (Selection m)
forEach Seq (Selection m)
forall a. Monoid a => a
mempty
  where
    forEach :: Field m -> Seq (Selection m) -> Seq (Selection m)
forEach (Transform.Field Maybe Text
_ Text
_ HashMap Text (Node Input)
_ Seq (Selection m)
fieldSelectionSet Location
_) Seq (Selection m)
selectionSet =
        Seq (Selection m)
selectionSet Seq (Selection m) -> Seq (Selection m) -> Seq (Selection m)
forall a. Semigroup a => a -> a -> a
<> Seq (Selection m)
fieldSelectionSet

firstFieldLocation :: MonadCatch m => NonEmpty (Transform.Field m) -> Full.Location
firstFieldLocation :: NonEmpty (Field m) -> Location
firstFieldLocation (Transform.Field Maybe Text
_ Text
_ HashMap Text (Node Input)
_ Seq (Selection m)
_ Location
fieldLocation :| [Field m]
_) = Location
fieldLocation

coerceResult :: (MonadCatch m, Serialize a)
    => Out.Type m
    -> Full.Location
    -> Output a
    -> CollectErrsT m a
coerceResult :: Type m -> Location -> Output a -> CollectErrsT m a
coerceResult Type m
outputType Location
parentLocation Output a
result
    | Just a
serialized <- Type m -> Output a -> Maybe a
forall a (m :: * -> *).
Serialize a =>
Type m -> Output a -> Maybe a
serialize Type m
outputType Output a
result = a -> CollectErrsT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
serialized
    | Bool
otherwise = a -> Error -> CollectErrsT m a
forall (m :: * -> *) a.
MonadCatch m =>
a -> Error -> CollectErrsT m a
addError a
forall a. Serialize a => a
null
        (Error -> CollectErrsT m a) -> Error -> CollectErrsT m a
forall a b. (a -> b) -> a -> b
$ Text -> [Location] -> [Path] -> Error
Error Text
"Result coercion failed." [Location
parentLocation] []

-- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies
-- each field to each 'Transform.Selection'. Resolves into a value containing
-- the resolved 'Transform.Selection', or a null value and error information.
executeSelectionSet :: (MonadCatch m, Serialize a)
    => Type.Value
    -> Out.ObjectType m
    -> Full.Location
    -> Seq (Transform.Selection m)
    -> CollectErrsT m a
executeSelectionSet :: Value
-> ObjectType m
-> Location
-> Seq (Selection m)
-> CollectErrsT m a
executeSelectionSet Value
result objectType :: ObjectType m
objectType@(Out.ObjectType Text
_ Maybe Text
_ [InterfaceType m]
_ HashMap Text (Resolver m)
resolvers) Location
objectLocation Seq (Selection m)
selectionSet = do
    let fields :: OrderedMap (NonEmpty (Field m))
fields = ObjectType m
-> Seq (Selection m) -> OrderedMap (NonEmpty (Field m))
forall (m :: * -> *).
Monad m =>
ObjectType m
-> Seq (Selection m) -> OrderedMap (NonEmpty (Field m))
collectFields ObjectType m
objectType Seq (Selection m)
selectionSet
    OrderedMap a
resolvedValues <- (NonEmpty (Field m) -> StateT (Resolution m) m (Maybe a))
-> OrderedMap (NonEmpty (Field m))
-> StateT (Resolution m) m (OrderedMap a)
forall (f :: * -> *) b a.
Applicative f =>
(a -> f (Maybe b)) -> OrderedMap a -> f (OrderedMap b)
OrderedMap.traverseMaybe NonEmpty (Field m) -> StateT (Resolution m) m (Maybe a)
forall b.
Serialize b =>
NonEmpty (Field m) -> StateT (Resolution m) m (Maybe b)
forEach OrderedMap (NonEmpty (Field m))
fields
    Type m -> Location -> Output a -> CollectErrsT m a
forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Type m -> Location -> Output a -> CollectErrsT m a
coerceResult (ObjectType m -> Type m
forall (m :: * -> *). ObjectType m -> Type m
Out.NonNullObjectType ObjectType m
objectType) Location
objectLocation
        (Output a -> CollectErrsT m a) -> Output a -> CollectErrsT m a
forall a b. (a -> b) -> a -> b
$ OrderedMap a -> Output a
forall a. OrderedMap a -> Output a
Object OrderedMap a
resolvedValues
  where
    forEach :: NonEmpty (Field m) -> StateT (Resolution m) m (Maybe b)
forEach fields :: NonEmpty (Field m)
fields@(Field m
field :| [Field m]
_) =
        let Transform.Field Maybe Text
_ Text
name HashMap Text (Node Input)
_ Seq (Selection m)
_ Location
_ = Field m
field
         in (Resolver m -> StateT (Resolution m) m b)
-> Maybe (Resolver m) -> StateT (Resolution m) m (Maybe b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (NonEmpty (Field m) -> Resolver m -> StateT (Resolution m) m b
forall (m :: * -> *) b.
(MonadCatch m, Serialize b) =>
NonEmpty (Field m) -> Resolver m -> StateT (Resolution m) m b
tryResolver NonEmpty (Field m)
fields) (Maybe (Resolver m) -> StateT (Resolution m) m (Maybe b))
-> Maybe (Resolver m) -> StateT (Resolution m) m (Maybe b)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Resolver m)
lookupResolver Text
name
    lookupResolver :: Text -> Maybe (Resolver m)
lookupResolver = (Text -> HashMap Text (Resolver m) -> Maybe (Resolver m))
-> HashMap Text (Resolver m) -> Text -> Maybe (Resolver m)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> HashMap Text (Resolver m) -> Maybe (Resolver m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup HashMap Text (Resolver m)
resolvers
    tryResolver :: NonEmpty (Field m) -> Resolver m -> StateT (Resolution m) m b
tryResolver NonEmpty (Field m)
fields Resolver m
resolver =
        Resolver m
-> Value -> NonEmpty (Field m) -> StateT (Resolution m) m b
forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Resolver m -> Value -> NonEmpty (Field m) -> CollectErrsT m a
executeField Resolver m
resolver Value
result NonEmpty (Field m)
fields StateT (Resolution m) m b
-> (b -> StateT (Resolution m) m b) -> StateT (Resolution m) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m b -> StateT (Resolution m) m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m b -> StateT (Resolution m) m b)
-> (b -> m b) -> b -> StateT (Resolution m) m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure

coerceArgumentValues
    :: HashMap Full.Name In.Argument
    -> HashMap Full.Name (Full.Node Transform.Input)
    -> Either [Full.Location] Type.Subs
coerceArgumentValues :: Arguments -> HashMap Text (Node Input) -> Either [Location] Subs
coerceArgumentValues Arguments
argumentDefinitions HashMap Text (Node Input)
argumentNodes =
    (Text
 -> Argument -> Either [Location] Subs -> Either [Location] Subs)
-> Either [Location] Subs -> Arguments -> Either [Location] Subs
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HashMap.foldrWithKey Text
-> Argument -> Either [Location] Subs -> Either [Location] Subs
forEach (Subs -> Either [Location] Subs
forall (f :: * -> *) a. Applicative f => a -> f a
pure Subs
forall a. Monoid a => a
mempty) Arguments
argumentDefinitions
  where
    forEach :: Text
-> Argument -> Either [Location] Subs -> Either [Location] Subs
forEach Text
argumentName (In.Argument Maybe Text
_ Type
variableType Maybe Value
defaultValue) = \case
        Right Subs
resultMap
            | Just Subs
matchedValues
                <- Text -> Type -> Maybe Value -> Maybe Subs -> Maybe Subs
matchFieldValues' Text
argumentName Type
variableType Maybe Value
defaultValue (Maybe Subs -> Maybe Subs) -> Maybe Subs -> Maybe Subs
forall a b. (a -> b) -> a -> b
$ Subs -> Maybe Subs
forall a. a -> Maybe a
Just Subs
resultMap
                -> Subs -> Either [Location] Subs
forall a b. b -> Either a b
Right Subs
matchedValues
            | Bool
otherwise -> [Location] -> Either [Location] Subs
forall a b. a -> Either a b
Left ([Location] -> Either [Location] Subs)
-> [Location] -> Either [Location] Subs
forall a b. (a -> b) -> a -> b
$ Text -> [Location] -> [Location]
generateError Text
argumentName []
        Left [Location]
errorLocations
            | Just Subs
_
                <- Text -> Type -> Maybe Value -> Maybe Subs -> Maybe Subs
matchFieldValues' Text
argumentName Type
variableType Maybe Value
defaultValue (Maybe Subs -> Maybe Subs) -> Maybe Subs -> Maybe Subs
forall a b. (a -> b) -> a -> b
$ Subs -> Maybe Subs
forall (f :: * -> *) a. Applicative f => a -> f a
pure Subs
forall a. Monoid a => a
mempty
                -> [Location] -> Either [Location] Subs
forall a b. a -> Either a b
Left [Location]
errorLocations
            | Bool
otherwise -> [Location] -> Either [Location] Subs
forall a b. a -> Either a b
Left ([Location] -> Either [Location] Subs)
-> [Location] -> Either [Location] Subs
forall a b. (a -> b) -> a -> b
$ Text -> [Location] -> [Location]
generateError Text
argumentName [Location]
errorLocations
    generateError :: Text -> [Location] -> [Location]
generateError Text
argumentName [Location]
errorLocations =
        case Text -> HashMap Text (Node Input) -> Maybe (Node Input)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
argumentName HashMap Text (Node Input)
argumentNodes of
            Just (Full.Node Input
_ Location
errorLocation) -> [Location
errorLocation]
            Maybe (Node Input)
Nothing -> [Location]
errorLocations
    matchFieldValues' :: Text -> Type -> Maybe Value -> Maybe Subs -> Maybe Subs
matchFieldValues' = (Type -> Input -> Maybe Value)
-> HashMap Text Input
-> Text
-> Type
-> Maybe Value
-> Maybe Subs
-> Maybe Subs
forall a.
(Type -> a -> Maybe Value)
-> HashMap Text a
-> Text
-> Type
-> Maybe Value
-> Maybe Subs
-> Maybe Subs
matchFieldValues Type -> Input -> Maybe Value
coerceArgumentValue (Node Input -> Input
forall a. Node a -> a
Full.node (Node Input -> Input)
-> HashMap Text (Node Input) -> HashMap Text Input
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Text (Node Input)
argumentNodes)
    coerceArgumentValue :: Type -> Input -> Maybe Value
coerceArgumentValue Type
inputType (Transform.Int Int32
integer) =
        Type -> Value -> Maybe Value
coerceInputLiteral Type
inputType (Int32 -> Value
Type.Int Int32
integer)
    coerceArgumentValue Type
inputType (Transform.Boolean Bool
boolean) =
        Type -> Value -> Maybe Value
coerceInputLiteral Type
inputType (Bool -> Value
Type.Boolean Bool
boolean)
    coerceArgumentValue Type
inputType (Transform.String Text
string) =
        Type -> Value -> Maybe Value
coerceInputLiteral Type
inputType (Text -> Value
Type.String Text
string)
    coerceArgumentValue Type
inputType (Transform.Float Double
float) =
        Type -> Value -> Maybe Value
coerceInputLiteral Type
inputType (Double -> Value
Type.Float Double
float)
    coerceArgumentValue Type
inputType (Transform.Enum Text
enum) =
        Type -> Value -> Maybe Value
coerceInputLiteral Type
inputType (Text -> Value
Type.Enum Text
enum)
    coerceArgumentValue Type
inputType Input
Transform.Null
        | Type -> Bool
In.isNonNullType Type
inputType = Maybe Value
forall a. Maybe a
Nothing
        | Bool
otherwise = Type -> Value -> Maybe Value
coerceInputLiteral Type
inputType Value
Type.Null
    coerceArgumentValue (In.ListBaseType Type
inputType) (Transform.List [Value]
list) =
        let coerceItem :: Value -> Maybe Value
coerceItem = Type -> Value -> Maybe Value
coerceInputLiteral Type
inputType
         in [Value] -> Value
Type.List ([Value] -> Value) -> Maybe [Value] -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Maybe Value) -> [Value] -> Maybe [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Maybe Value
coerceItem [Value]
list
    coerceArgumentValue (In.InputObjectBaseType InputObjectType
inputType) (Transform.Object HashMap Text Input
object)
        | In.InputObjectType Text
_ Maybe Text
_ HashMap Text InputField
inputFields <- InputObjectType
inputType = 
            let go :: Text -> InputField -> Maybe Subs -> Maybe Subs
go = HashMap Text Input
-> Text -> InputField -> Maybe Subs -> Maybe Subs
forEachField HashMap Text Input
object
                resultMap :: Maybe Subs
resultMap = (Text -> InputField -> Maybe Subs -> Maybe Subs)
-> Maybe Subs -> HashMap Text InputField -> Maybe Subs
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HashMap.foldrWithKey Text -> InputField -> Maybe Subs -> Maybe Subs
go (Subs -> Maybe Subs
forall (f :: * -> *) a. Applicative f => a -> f a
pure Subs
forall a. Monoid a => a
mempty) HashMap Text InputField
inputFields
             in Subs -> Value
Type.Object (Subs -> Value) -> Maybe Subs -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Subs
resultMap
    coerceArgumentValue Type
_ (Transform.Variable Value
variable) = Value -> Maybe Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
variable
    coerceArgumentValue Type
_ Input
_ = Maybe Value
forall a. Maybe a
Nothing
    forEachField :: HashMap Text Input
-> Text -> InputField -> Maybe Subs -> Maybe Subs
forEachField HashMap Text Input
object Text
variableName (In.InputField Maybe Text
_ Type
variableType Maybe Value
defaultValue) =
        (Type -> Input -> Maybe Value)
-> HashMap Text Input
-> Text
-> Type
-> Maybe Value
-> Maybe Subs
-> Maybe Subs
forall a.
(Type -> a -> Maybe Value)
-> HashMap Text a
-> Text
-> Type
-> Maybe Value
-> Maybe Subs
-> Maybe Subs
matchFieldValues Type -> Input -> Maybe Value
coerceArgumentValue HashMap Text Input
object Text
variableName Type
variableType Maybe Value
defaultValue