Coerce argument values properly

Fixes #44.

CHANGELOG.md

@@ -15,6 +15,8 @@ and this project adheres to
 - AST transformation should never fail.
     * Missing variable are assumed to be null.
     * Invalid (recusrive or non-existing) fragments should be skipped.
+- Argument value coercion.
+- Variable value coercion.
 
 ### Changed
 - `Schema.Resolver` was moved to `Type.Out`, it is a field and resolver function

src/Language/GraphQL/Execute/Coerce.hs

@@ -1,20 +1,22 @@
+{-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 -- | Types and functions used for input and result coercion.
 module Language.GraphQL.Execute.Coerce
     ( VariableValue(..)
-    , coerceInputLiterals
+    , coerceInputLiteral
+    , matchFieldValues
     ) where
 
 import qualified Data.Aeson as Aeson
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
-import qualified Data.Set as Set
 import qualified Data.Text.Lazy as Text.Lazy
 import qualified Data.Text.Lazy.Builder as Text.Builder
 import qualified Data.Text.Lazy.Builder.Int as Text.Builder
+import qualified Data.Set as Set
 import Data.Scientific (toBoundedInteger, toRealFloat)
-import Language.GraphQL.AST.Document (Name)
+import Language.GraphQL.AST.Core
 import qualified Language.GraphQL.Type.In as In
 import Language.GraphQL.Type.Definition
 
@@ -67,10 +69,10 @@ instance VariableValue Aeson.Value where
                 then Just $ Object resultMap
                 else Nothing
       where
-        foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues
+        foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues'
             $ Just (objectValue, HashMap.empty)
-        matchFieldValues _ _ Nothing = Nothing
+        matchFieldValues' _ _ Nothing = Nothing
-        matchFieldValues fieldName inputField (Just (objectValue, resultMap)) =
+        matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) =
             let (In.InputField _ fieldType _) = inputField
                 insert = flip (HashMap.insert fieldName) resultMap
                 newObjectValue = HashMap.delete fieldName objectValue
@@ -90,60 +92,67 @@ instance VariableValue Aeson.Value where
             pure $ coerced : list 
     coerceVariableValue _ _ = Nothing
 
--- | Coerces operation arguments according to the input coercion rules for the
+-- | Looks up a value by name in the given map, coerces it and inserts into the
---   corresponding types.
+-- result map. If the coercion fails, returns 'Nothing'. If the value isn't
-coerceInputLiterals
+-- given, but a default value is known, inserts the default value into the
-    :: HashMap Name In.Type
+-- result map. Otherwise it fails with 'Nothing' if the Input Type is a
-    -> HashMap Name Value
+-- Non-Nullable type, or returns the unchanged, original map.
-    -> Maybe Subs
+matchFieldValues :: forall a
-coerceInputLiterals variableTypes variableValues =
+    . (In.Type -> a -> Maybe Value)
-    foldWithKey operator variableTypes
+    -> HashMap Name a
+    -> Name
+    -> In.Type
+    -> Maybe Value
+    -> Maybe (HashMap Name Value)
+    -> Maybe (HashMap Name Value)
+matchFieldValues coerce values' fieldName type' defaultValue resultMap =
+    case HashMap.lookup fieldName values' of
+        Just variableValue -> coerceRuntimeValue $ coerce type' variableValue
+        Nothing
+            | Just value <- defaultValue ->
+                HashMap.insert fieldName value <$> resultMap
+            | Nothing <- defaultValue
+            , In.isNonNullType type' -> Nothing
+            | otherwise -> resultMap
+  where
+    coerceRuntimeValue (Just Null)
+        | In.isNonNullType type' = Nothing
+    coerceRuntimeValue coercedValue =
+        HashMap.insert fieldName <$> coercedValue <*> resultMap
+
+-- | Coerces operation arguments according to the input coercion rules for the
+-- corresponding types.
+coerceInputLiteral :: In.Type -> Value -> Maybe Value
+coerceInputLiteral (In.ScalarBaseType type') value
+    | (String stringValue) <- value
+    , (ScalarType "String" _) <- type' = Just $ String stringValue
+    | (Boolean booleanValue) <- value
+    , (ScalarType "Boolean" _) <- type' = Just $ Boolean booleanValue
+    | (Int intValue) <- value
+    , (ScalarType "Int" _) <- type' = Just $ Int intValue
+    | (Float floatValue) <- value
+    , (ScalarType "Float" _) <- type' = Just $ Float floatValue
+    | (Int intValue) <- value
+    , (ScalarType "Float" _) <- type' =
+        Just $ Float $ fromIntegral intValue
+    | (String stringValue) <- value
+    , (ScalarType "ID" _) <- type' = Just $ String stringValue
+    | (Int intValue) <- value
+    , (ScalarType "ID" _) <- type' = Just $ decimal intValue
   where
-    operator variableName variableType resultMap =
-        HashMap.insert variableName
-        <$> (lookupVariable variableName >>= coerceInputLiteral variableType)
-        <*> resultMap
-    coerceInputLiteral (In.NamedScalarType type') value
-        | (String stringValue) <- value
-        , (ScalarType "String" _) <- type' = Just $ String stringValue
-        | (Boolean booleanValue) <- value
-        , (ScalarType "Boolean" _) <- type' = Just $ Boolean booleanValue
-        | (Int intValue) <- value
-        , (ScalarType "Int" _) <- type' = Just $ Int intValue
-        | (Float floatValue) <- value
-        , (ScalarType "Float" _) <- type' = Just $ Float floatValue
-        | (Int intValue) <- value
-        , (ScalarType "Float" _) <- type' =
-            Just $ Float $ fromIntegral intValue
-        | (String stringValue) <- value
-        , (ScalarType "ID" _) <- type' = Just $ String stringValue
-        | (Int intValue) <- value
-        , (ScalarType "ID" _) <- type' = Just $ decimal intValue
-    coerceInputLiteral (In.NamedEnumType type') (Enum enumValue)
-        | member enumValue type' = Just $ Enum enumValue
-    coerceInputLiteral (In.NamedInputObjectType type') (Object _) = 
-        let (In.InputObjectType _ _ inputFields) = type'
-            in Object <$> foldWithKey matchFieldValues inputFields
-    coerceInputLiteral _ _ = Nothing
-    member value (EnumType _ _ members) = Set.member value members
-    matchFieldValues fieldName (In.InputField _ type' defaultValue) resultMap =
-        case lookupVariable fieldName of
-            Just Null
-                | In.isNonNullType type' -> Nothing
-                | otherwise ->
-                    HashMap.insert fieldName Null <$> resultMap
-            Just variableValue -> HashMap.insert fieldName
-                <$> coerceInputLiteral type' variableValue
-                <*> resultMap
-            Nothing
-                | Just value <- defaultValue ->
-                    HashMap.insert fieldName value <$> resultMap
-                | Nothing <- defaultValue
-                , In.isNonNullType type' -> Nothing
-                | otherwise -> resultMap
-    lookupVariable = flip HashMap.lookup variableValues
-    foldWithKey f = HashMap.foldrWithKey f (Just HashMap.empty)
     decimal = String
         . Text.Lazy.toStrict
         . Text.Builder.toLazyText
         . Text.Builder.decimal
+coerceInputLiteral (In.EnumBaseType type') (Enum enumValue)
+    | member enumValue type' = Just $ Enum enumValue
+  where
+    member value (EnumType _ _ members) = Set.member value members
+coerceInputLiteral (In.InputObjectBaseType type') (Object values) = 
+    let (In.InputObjectType _ _ inputFields) = type'
+        in Object
+            <$> HashMap.foldrWithKey (matchFieldValues' values) (Just HashMap.empty) inputFields
+  where
+    matchFieldValues' values' fieldName (In.InputField _ inputFieldType defaultValue) =
+        matchFieldValues coerceInputLiteral values' fieldName inputFieldType defaultValue
+coerceInputLiteral _ _ = Nothing

src/Language/GraphQL/Execute/Execution.hs

@@ -19,17 +19,23 @@ import Data.Sequence (Seq(..))
 import Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Sequence as Seq
-import Language.GraphQL.AST.Document (Name)
+import Language.GraphQL.AST.Core
 import Language.GraphQL.Error
+import Language.GraphQL.Execute.Coerce
 import Language.GraphQL.Execute.Transform
 import Language.GraphQL.Trans
-import Language.GraphQL.Type.Definition
+import qualified Language.GraphQL.Type.Definition as Definition
+import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Type.Schema
 
-resolveFieldValue :: Monad m => Value -> Field m -> ActionT m a -> m (Either Text a)
+resolveFieldValue :: Monad m
-resolveFieldValue result (Field _ _ args _) =
+    => Definition.Value
-    flip runReaderT (Context {arguments=args, values=result})
+    -> Definition.Subs
+    -> ActionT m a
+    -> m (Either Text a)
+resolveFieldValue result args =
+    flip runReaderT (Context {arguments = Arguments args, values = result})
     . runExceptT
     . runActionT
 
@@ -54,10 +60,10 @@ aliasOrName (Field alias name _ _) = fromMaybe name alias
 
 resolveAbstractType :: Monad m
     => AbstractType m
-    -> HashMap Name Value
+    -> HashMap Name Definition.Value
     -> CollectErrsT m (Maybe (Out.ObjectType m))
 resolveAbstractType abstractType values'
-    | Just (String typeName) <- HashMap.lookup "__typename" values' = do
+    | Just (Definition.String typeName) <- HashMap.lookup "__typename" values' = do
         types' <- gets types
         case HashMap.lookup typeName types' of
             Just (ObjectType objectType) ->
@@ -97,40 +103,44 @@ instanceOf objectType (AbstractUnionType unionType) =
          in acc || this == that
 
 executeField :: Monad m
-    => Value
+    => Definition.Value
     -> Out.Resolver m
     -> Field m
     -> CollectErrsT m Aeson.Value
 executeField prev (Out.Resolver fieldDefinition resolver) field = do
-    let Out.Field _ fieldType _ = fieldDefinition
+    let Out.Field _ fieldType argumentDefinitions = fieldDefinition
-    answer <- lift $ resolveFieldValue prev field resolver
+    let Field _ _ arguments' _ = field
-    case answer of
+    case coerceArgumentValues argumentDefinitions arguments' of
-        Right result -> completeValue fieldType field result
+        Nothing -> errmsg "Argument coercing failed."
-        Left errorMessage -> errmsg errorMessage
+        Just argumentValues -> do
+            answer <- lift $ resolveFieldValue prev argumentValues resolver
+            case answer of
+                Right result -> completeValue fieldType field result
+                Left errorMessage -> errmsg errorMessage
 
 completeValue :: Monad m
     => Out.Type m
     -> Field m
-    -> Value
+    -> Definition.Value
     -> CollectErrsT m Aeson.Value
-completeValue _ _ Null = pure Aeson.Null
+completeValue _ _ Definition.Null = pure Aeson.Null
-completeValue _ _ (Int integer) = pure $ Aeson.toJSON integer
+completeValue _ _ (Definition.Int integer) = pure $ Aeson.toJSON integer
-completeValue _ _ (Boolean boolean') = pure $ Aeson.Bool boolean'
+completeValue _ _ (Definition.Boolean boolean') = pure $ Aeson.Bool boolean'
-completeValue _ _ (Float float') = pure $ Aeson.toJSON float'
+completeValue _ _ (Definition.Float float') = pure $ Aeson.toJSON float'
-completeValue _ _ (Enum enum) = pure $ Aeson.String enum
+completeValue _ _ (Definition.Enum enum) = pure $ Aeson.String enum
-completeValue _ _ (String string') = pure $ Aeson.String string'
+completeValue _ _ (Definition.String string') = pure $ Aeson.String string'
 completeValue (Out.ObjectBaseType objectType) (Field _ _ _ seqSelection) result =
     executeSelectionSet result objectType seqSelection
-completeValue (Out.ListBaseType listType) selectionField (List list) =
+completeValue (Out.ListBaseType listType) selectionField (Definition.List list) =
     Aeson.toJSON <$> traverse (completeValue listType selectionField) list
 completeValue (Out.InterfaceBaseType interfaceType) (Field _ _ _ seqSelection) result
-    | Object objectMap <- result = do
+    | Definition.Object objectMap <- result = do
         abstractType <- resolveAbstractType (AbstractInterfaceType interfaceType) objectMap
         case abstractType of
             Just objectType -> executeSelectionSet result objectType seqSelection
             Nothing -> errmsg "Value completion failed."
 completeValue (Out.UnionBaseType unionType) (Field _ _ _ seqSelection) result
-    | Object objectMap <- result = do
+    | Definition.Object objectMap <- result = do
         abstractType <- resolveAbstractType (AbstractUnionType unionType) objectMap
         case abstractType of
             Just objectType -> executeSelectionSet result objectType seqSelection
@@ -144,7 +154,7 @@ errmsg errorMessage = addErrMsg errorMessage >> pure Aeson.Null
 -- to each 'Selection'. Resolves into a value containing the resolved
 -- 'Selection', or a null value and error information.
 executeSelectionSet :: Monad m
-    => Value
+    => Definition.Value
     -> Out.ObjectType m
     -> Seq (Selection m)
     -> CollectErrsT m Aeson.Value
@@ -161,3 +171,38 @@ executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selection
         | Just typeField <- lookupResolver name =
             executeField result typeField fld
         | otherwise = errmsg $ Text.unwords ["field", name, "not resolved."]
+
+coerceArgumentValues
+    :: HashMap Name In.Argument
+    -> HashMap Name Input
+    -> Maybe Definition.Subs
+coerceArgumentValues argumentDefinitions argumentValues =
+    HashMap.foldrWithKey forEach (pure mempty) argumentDefinitions
+  where
+    forEach variableName (In.Argument _ variableType defaultValue) =
+        matchFieldValues coerceArgumentValue argumentValues variableName variableType defaultValue
+    coerceArgumentValue inputType (Int integer) =
+        coerceInputLiteral inputType (Definition.Int integer)
+    coerceArgumentValue inputType (Boolean boolean) =
+        coerceInputLiteral inputType (Definition.Boolean boolean)
+    coerceArgumentValue inputType (String string) =
+        coerceInputLiteral inputType (Definition.String string)
+    coerceArgumentValue inputType (Float float) =
+        coerceInputLiteral inputType (Definition.Float float)
+    coerceArgumentValue inputType (Enum enum) =
+        coerceInputLiteral inputType (Definition.Enum enum)
+    coerceArgumentValue inputType Null
+        | In.isNonNullType inputType = Nothing
+        | otherwise = coerceInputLiteral inputType Definition.Null
+    coerceArgumentValue (In.ListBaseType inputType) (List list) =
+        let coerceItem = coerceInputLiteral inputType
+         in Definition.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 Definition.Object <$> resultMap
+    coerceArgumentValue _ (Variable variable) = pure variable
+    coerceArgumentValue _ _ = Nothing
+    forEachField object variableName (In.InputField _ variableType defaultValue) =
+        matchFieldValues coerceArgumentValue object variableName variableType defaultValue

src/Language/GraphQL/Execute/Transform.hs

@@ -18,11 +18,12 @@
 -- the original AST.
 module Language.GraphQL.Execute.Transform
     ( Document(..)
-    , Fragment(..)
-    , QueryError(..)
-    , Operation(..)
-    , Selection(..)
     , Field(..)
+    , Fragment(..)
+    , Input(..)
+    , Operation(..)
+    , QueryError(..)
+    , Selection(..)
     , document
     , queryError
     ) where
@@ -34,6 +35,7 @@ import Data.Foldable (find)
 import Data.Functor.Identity (Identity(..))
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
+import Data.Int (Int32)
 import Data.Maybe (fromMaybe)
 import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NonEmpty
@@ -43,19 +45,18 @@ import qualified Data.Text as Text
 import qualified Language.GraphQL.AST as Full
 import Language.GraphQL.AST.Core
 import Language.GraphQL.Execute.Coerce
+import Language.GraphQL.Type.Directive (Directive(..))
 import qualified Language.GraphQL.Type.Directive as Directive
-import Language.GraphQL.Type.Definition (Subs, Value(..))
+import qualified Language.GraphQL.Type.Definition as Definition
-import qualified Language.GraphQL.AST.Core as Core
 import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out
-import qualified Language.GraphQL.Type.Directive as Core
 import Language.GraphQL.Type.Schema
 
--- | Associates a fragment name with a list of 'Core.Field's.
+-- | Associates a fragment name with a list of 'Field's.
 data Replacement m = Replacement
     { fragments :: HashMap Full.Name (Fragment m)
     , fragmentDefinitions :: FragmentDefinitions
-    , variableValues :: Subs
+    , variableValues :: Definition.Subs
     , types :: HashMap Full.Name (Type m)
     }
 
@@ -78,7 +79,8 @@ data Operation m
     | Mutation (Maybe Text) (Seq (Selection m))
 
 -- | Single GraphQL field.
-data Field m = Field (Maybe Full.Name) Full.Name Arguments (Seq (Selection m))
+data Field m = Field
+    (Maybe Full.Name) Full.Name (HashMap Full.Name Input) (Seq (Selection m))
 
 -- | Contains the operation to be executed along with its root type.
 data Document m = Document
@@ -100,6 +102,18 @@ data QueryError
     | EmptyDocument
     | UnsupportedRootOperation
 
+data Input
+    = Int Int32
+    | Float Double
+    | String Text
+    | Boolean Bool
+    | Null
+    | Enum Name
+    | List [Definition.Value]
+    | Object (HashMap Name Input)
+    | Variable Definition.Value
+    deriving (Eq, Show)
+
 queryError :: QueryError -> Text
 queryError (OperationNotFound operationName) = Text.unwords
     ["Operation", operationName, "couldn't be found in the document."]
@@ -158,41 +172,33 @@ coerceVariableValues :: VariableValue a
     . HashMap Full.Name (Type m)
     -> OperationDefinition
     -> HashMap.HashMap Full.Name a
-    -> Either QueryError Subs
+    -> Either QueryError Definition.Subs
-coerceVariableValues types operationDefinition variableValues' =
+coerceVariableValues types operationDefinition variableValues =
     let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition
      in maybe (Left CoercionError) Right
-        $ foldr coerceValue (Just HashMap.empty) variableDefinitions
+        $ foldr forEach (Just HashMap.empty) variableDefinitions
   where
-    coerceValue variableDefinition coercedValues = do
+    forEach variableDefinition coercedValues = do
         let Full.VariableDefinition variableName variableTypeName defaultValue =
                 variableDefinition
         let defaultValue' = constValue <$> defaultValue
-        let value' = HashMap.lookup variableName variableValues'
-
         variableType <- lookupInputType variableTypeName types
-        HashMap.insert variableName
-            <$> choose value' defaultValue' variableType
-            <*> coercedValues
-    choose Nothing defaultValue variableType
-        | Just _ <- defaultValue = defaultValue
-        | not (In.isNonNullType variableType) = Just Null
-    choose (Just value') _ variableType
-        | Just coercedValue <- coerceVariableValue variableType value'
-        , not (In.isNonNullType variableType) || coercedValue /= Null =
-            Just coercedValue
-    choose _ _ _ = Nothing
 
-constValue :: Full.ConstValue -> Value
+        matchFieldValues coerceVariableValue' variableValues variableName variableType defaultValue' coercedValues
-constValue (Full.ConstInt i) = Int i
+    coerceVariableValue' variableType value'
-constValue (Full.ConstFloat f) = Float f
+        = coerceVariableValue variableType value'
-constValue (Full.ConstString x) = String x
+        >>= coerceInputLiteral variableType
-constValue (Full.ConstBoolean b) = Boolean b
+
-constValue Full.ConstNull = Null
+constValue :: Full.ConstValue -> Definition.Value
-constValue (Full.ConstEnum e) = Enum e
+constValue (Full.ConstInt i) = Definition.Int i
-constValue (Full.ConstList l) = List $ constValue <$> l
+constValue (Full.ConstFloat f) = Definition.Float f
+constValue (Full.ConstString x) = Definition.String x
+constValue (Full.ConstBoolean b) = Definition.Boolean b
+constValue Full.ConstNull = Definition.Null
+constValue (Full.ConstEnum e) = Definition.Enum e
+constValue (Full.ConstList l) = Definition.List $ constValue <$> l
 constValue (Full.ConstObject o) =
-    Object $ HashMap.fromList $ constObjectField <$> o
+    Definition.Object $ HashMap.fromList $ constObjectField <$> o
   where
     constObjectField (Full.ObjectField key value') = (key, constValue value')
 
@@ -271,11 +277,15 @@ selection
     ->  State (Replacement m) (Either (Seq (Selection m)) (Selection m))
 selection (Full.Field alias name arguments' directives' selections) =
     maybe (Left mempty) (Right . SelectionField) <$> do
-        fieldArguments <- arguments arguments'
+        fieldArguments <- foldM go HashMap.empty arguments'
         fieldSelections <- appendSelection selections
         fieldDirectives <- Directive.selection <$> directives directives'
         let field' = Field alias name fieldArguments fieldSelections
         pure $ field' <$ fieldDirectives
+  where
+    go arguments (Full.Argument name' value') =
+        inputField arguments name' value'
+
 selection (Full.FragmentSpread name directives') =
     maybe (Left mempty) (Right . SelectionFragment) <$> do
         spreadDirectives <- Directive.selection <$> directives directives'
@@ -320,11 +330,15 @@ appendSelection = foldM go mempty
     append acc (Left list) = list >< acc
     append acc (Right one) = one <| acc
 
-directives :: [Full.Directive] ->  State (Replacement m) [Core.Directive]
+directives :: [Full.Directive] ->  State (Replacement m) [Directive]
 directives = traverse directive
   where
-    directive (Full.Directive directiveName directiveArguments) =
+    directive (Full.Directive directiveName directiveArguments)
-        Core.Directive directiveName <$> arguments directiveArguments
+        = Directive directiveName . Arguments
+        <$> foldM go HashMap.empty directiveArguments
+    go arguments (Full.Argument name value') = do
+        substitutedValue <- value value'
+        return $ HashMap.insert name substitutedValue arguments
 
 -- * Fragment replacement
 
@@ -371,27 +385,45 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
         let newFragments = HashMap.insert name newValue fragments
          in replacement{ fragments = newFragments }
 
-arguments :: [Full.Argument] -> State (Replacement m) Core.Arguments
+value :: forall m. Full.Value -> State (Replacement m) Definition.Value
-arguments = fmap Core.Arguments . foldM go HashMap.empty
-  where
-    go arguments' (Full.Argument name value') = do
-        substitutedValue <- value value'
-        return $ HashMap.insert name substitutedValue arguments'
-
-value :: Full.Value -> State (Replacement m) Value
 value (Full.Variable name) =
-    gets $ fromMaybe Null . HashMap.lookup name . variableValues
+    gets (fromMaybe Definition.Null . HashMap.lookup name . variableValues)
-value (Full.Int i) = pure $ Int i
+value (Full.Int i) = pure $ Definition.Int i
-value (Full.Float f) = pure $ Float f
+value (Full.Float f) = pure $ Definition.Float f
-value (Full.String x) = pure $ String x
+value (Full.String x) = pure $ Definition.String x
-value (Full.Boolean b) = pure $ Boolean b
+value (Full.Boolean b) = pure $ Definition.Boolean b
-value Full.Null = pure   Null
+value Full.Null = pure Definition.Null
-value (Full.Enum e) = pure $ Enum e
+value (Full.Enum e) = pure $ Definition.Enum e
-value (Full.List l) = List <$> traverse value l
+value (Full.List l) = Definition.List <$> traverse value l
 value (Full.Object o) =
-    Object . HashMap.fromList <$> traverse objectField o
+    Definition.Object . HashMap.fromList <$> traverse objectField o
+  where
+    objectField (Full.ObjectField name value') = (name,) <$> value value'
 
-objectField
+input :: forall m. Full.Value -> State (Replacement m) (Maybe Input)
-    :: Full.ObjectField Full.Value
+input (Full.Variable name) =
-    -> State (Replacement m) (Full.Name, Value)
+    gets (fmap Variable . HashMap.lookup name . variableValues)
-objectField (Full.ObjectField name value') = (name,) <$> value value'
+input (Full.Int i) = pure $ pure $ Int i
+input (Full.Float f) = pure $ pure $ Float f
+input (Full.String x) = pure $ pure $ String x
+input (Full.Boolean b) = pure $ pure $ Boolean b
+input Full.Null = pure $ pure Null
+input (Full.Enum e) = pure $ pure $ Enum e
+input (Full.List list) = pure . List <$> traverse value list
+input (Full.Object object) = do
+    objectFields <- foldM objectField HashMap.empty object
+    pure $ pure $ Object objectFields
+  where
+    objectField resultMap (Full.ObjectField name value') =
+        inputField resultMap name value'
+
+inputField :: forall m
+    . HashMap Full.Name Input
+    -> Full.Name
+    -> Full.Value
+    -> State (Replacement m) (HashMap Full.Name Input)
+inputField resultMap name value' = do
+    objectFieldValue <-  input value'
+    case objectFieldValue of
+        Just fieldValue -> pure $ HashMap.insert name fieldValue resultMap
+        Nothing -> pure resultMap

tests/Language/GraphQL/Execute/CoerceSpec.hs

@@ -6,12 +6,10 @@ module Language.GraphQL.Execute.CoerceSpec
 import Data.Aeson as Aeson ((.=))
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson
-import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
 import Data.Maybe (isNothing)
 import Data.Scientific (scientific)
 import qualified Data.Set as Set
-import Language.GraphQL.AST.Document (Name)
 import Language.GraphQL.Execute.Coerce
 import Language.GraphQL.Type.Definition
 import qualified Language.GraphQL.Type.In as In
@@ -22,14 +20,6 @@ direction :: EnumType
 direction = EnumType "Direction" Nothing 
     $ Set.fromList ["NORTH", "EAST", "SOUTH", "WEST"]
 
-coerceInputLiteral :: In.Type -> Value -> Maybe Subs
-coerceInputLiteral input value = coerceInputLiterals
-    (HashMap.singleton "variableName" input)
-    (HashMap.singleton "variableName" value)
-
-lookupActual :: Maybe (HashMap Name Value) -> Maybe Value
-lookupActual = (HashMap.lookup "variableName" =<<)
-
 singletonInputObject :: In.Type
 singletonInputObject = In.NamedInputObjectType type'
   where
@@ -39,7 +29,7 @@ singletonInputObject = In.NamedInputObjectType type'
 
 spec :: Spec
 spec = do
-    describe "ToGraphQL Aeson" $ do
+    describe "VariableValue Aeson" $ do
         it "coerces strings" $
             let expected = Just (String "asdf")
                 actual = coerceVariableValue
@@ -107,7 +97,7 @@ spec = do
             let expected = Just (Enum "NORTH")
                 actual = coerceInputLiteral
                     (In.NamedEnumType direction) (Enum "NORTH")
-             in lookupActual actual `shouldBe` expected
+             in actual `shouldBe` expected
         it "fails with non-existing enum value" $
             let actual = coerceInputLiteral
                     (In.NamedEnumType direction) (Enum "NORTH_EAST")
@@ -115,4 +105,4 @@ spec = do
         it "coerces integers to IDs" $
             let expected = Just (String "1234")
                 actual = coerceInputLiteral (In.NamedScalarType id) (Int 1234)
-             in lookupActual actual `shouldBe` expected
+             in actual `shouldBe` expected

tests/Test/StarWars/Schema.hs

@@ -11,10 +11,12 @@ import Data.Functor.Identity (Identity)
 import qualified Data.HashMap.Strict as HashMap
 import Data.Maybe (catMaybes)
 import Data.Text (Text)
+import qualified Data.Set as Set
 import Language.GraphQL.Trans
 import Language.GraphQL.Type.Definition
+import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out
-import Language.GraphQL.Type.Schema
+import Language.GraphQL.Type.Schema (Schema(..))
 import Test.StarWars.Data
 import Prelude hiding (id)
 
@@ -24,10 +26,17 @@ schema :: Schema Identity
 schema = Schema { query = queryType, mutation = Nothing }
   where
     queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
-        [ ("hero", Out.Resolver (Out.Field Nothing (Out.NamedObjectType heroObject) mempty) hero)
+        [ ("hero", Out.Resolver heroField hero)
-        , ("human", Out.Resolver (Out.Field Nothing (Out.NamedObjectType heroObject) mempty) human)
+        , ("human", Out.Resolver humanField human)
-        , ("droid", Out.Resolver (Out.Field Nothing (Out.NamedObjectType droidObject) mempty) droid)
+        , ("droid", Out.Resolver droidField droid)
         ]
+    heroField = Out.Field Nothing (Out.NamedObjectType heroObject)
+        $ HashMap.singleton "episode"
+        $ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing
+    humanField = Out.Field Nothing (Out.NamedObjectType heroObject)
+        $ HashMap.singleton "id"
+        $ In.Argument Nothing (In.NonNullScalarType string) Nothing
+    droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty
 
 heroObject :: Out.ObjectType Identity
 heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
@@ -76,6 +85,10 @@ idField f = do
     let (Object v') = v
     pure $ v' HashMap.! f
 
+episodeEnum :: EnumType
+episodeEnum = EnumType "Episode" Nothing
+    $ Set.fromList ["NEW_HOPE", "EMPIRE", "JEDI"]
+
 hero :: ActionT Identity Value
 hero = do
   episode <- argument "episode"