Coerce variable values

CHANGELOG.md

@@ -12,12 +12,30 @@ and this project adheres to
   contain a JSON value or another resolver, which is invoked during the
   execution. `FieldResolver` is executed in `ActionT` and the current `Field` is
   passed in the reader and not as an explicit argument.
+- `Execute.Transform.OperationDefinition` is almost the same as
+  `AST.Document.OperationDefinition`. It is used to unify operations in the
+  shorthand form and other operations.
+- `Execute.Transform.operation` has the prior responsibility of
+  `Execute.Transform.document`, but transforms only the chosen operation and not
+  the whole document. `Execute.Transform.document` translates
+  `AST.Document.Document` into `Execute.Transform.Document`.
 
 ### Added
-- `Type.Definition` and `Type.Schema` modules. Both contain the first types (but
+- `Type.Definition` contains input and the most output types.
-  not all yet) to describe a schema. Public functions that execute queries
+- `Type.Schema` describes a schema. Both public functions that execute queries
   accept a `Schema` now instead of a `HashMap`. The execution fails if the root
   operation doesn't match the root Query type in the schema.
+- `Execute.Coerce` defines a typeclass responsible for input, variable value
+  coercion. It decouples us a bit from JSON since any format can be used to pass
+  query variables. Execution functions accept (`HashMap Name a`) instead of
+  `Subs`, where a is an instance of `VariableValue`.
+
+### Removed
+- `AST.Core.Document`. Transforming the whole document is probably not
+  reasonable since a document can define multiple operations and we're
+  interested only in one of them. Therefore `Document` was modified and moved to
+  `Execute.Transform`. It contains only slightly modified AST used to pick the
+  operation.
 
 ## [0.7.0.0] - 2020-05-11
 ### Fixed

docs/tutorial/tutorial.lhs

@@ -39,7 +39,9 @@ First we build a GraphQL schema.
 > schema1 = Schema queryType Nothing
 >
 > queryType :: ObjectType IO
-> queryType = ObjectType "Query" $ Schema.resolversToMap $ hello :| []
+> queryType = ObjectType "Query"
+>   $ Field Nothing (ScalarOutputType string) mempty
+>   <$> Schema.resolversToMap (hello :| [])
 >
 > hello :: Schema.Resolver IO
 > hello = Schema.scalar "hello" (return ("it's me" :: Text))
@@ -72,7 +74,9 @@ For this example, we're going to be using time.
 > schema2 = Schema queryType2 Nothing
 >
 > queryType2 :: ObjectType IO
-> queryType2 = ObjectType "Query" $ Schema.resolversToMap $ time :| []
+> queryType2 = ObjectType "Query"
+>   $ Field Nothing (ScalarOutputType string) mempty
+>   <$> Schema.resolversToMap (time :| [])
 >
 > time :: Schema.Resolver IO
 > time = Schema.scalar "time" $ do
@@ -134,7 +138,9 @@ Now that we have two resolvers, we can define a schema which uses them both.
 > schema3 = Schema queryType3 Nothing
 >
 > queryType3 :: ObjectType IO
-> queryType3 = ObjectType "Query" $ Schema.resolversToMap $ hello :| [time]
+> queryType3 = ObjectType "Query"
+>   $ Field Nothing (ScalarOutputType string) mempty
+>   <$> Schema.resolversToMap (hello :| [time])
 >
 > query3 :: Text
 > query3 = "query timeAndHello { time hello }"

package.yaml

@@ -31,6 +31,7 @@ dependencies:
 - containers
 - megaparsec
 - parser-combinators
+- scientific
 - text
 - transformers
 - unordered-containers

src/Language/GraphQL.hs

@@ -5,11 +5,13 @@ module Language.GraphQL
     ) where
 
 import qualified Data.Aeson as Aeson
+import Data.HashMap.Strict (HashMap)
 import Data.Text (Text)
+import Language.GraphQL.AST.Document
+import Language.GraphQL.AST.Parser
 import Language.GraphQL.Error
 import Language.GraphQL.Execute
-import Language.GraphQL.AST.Parser
+import Language.GraphQL.Execute.Coerce
-import qualified Language.GraphQL.Schema as Schema
 import Language.GraphQL.Type.Schema
 import Text.Megaparsec (parse)
 
@@ -19,14 +21,14 @@ graphql :: Monad m
     => Schema m -- ^ Resolvers.
     -> Text -- ^ Text representing a @GraphQL@ request document.
     -> m Aeson.Value -- ^ Response.
-graphql = flip graphqlSubs mempty
+graphql = flip graphqlSubs (mempty :: Aeson.Object)
 
 -- | If the text parses correctly as a @GraphQL@ query the substitution is
 -- applied to the query and the query is then executed using to the given
 -- 'Schema.Resolver's.
-graphqlSubs :: Monad m
+graphqlSubs :: (Monad m, VariableValue a)
     => Schema m -- ^ Resolvers.
-    -> Schema.Subs -- ^ Variable substitution function.
+    -> HashMap Name a -- ^ Variable substitution function.
     -> Text -- ^ Text representing a @GraphQL@ request document.
     -> m Aeson.Value -- ^ Response.
 graphqlSubs schema f

src/Language/GraphQL/AST/Core.hs

@@ -3,7 +3,6 @@ module Language.GraphQL.AST.Core
     ( Alias
     , Arguments(..)
     , Directive(..)
-    , Document
     , Field(..)
     , Fragment(..)
     , Name
@@ -15,15 +14,11 @@ module Language.GraphQL.AST.Core
 
 import Data.Int (Int32)
 import Data.HashMap.Strict (HashMap)
-import Data.List.NonEmpty (NonEmpty)
 import Data.Sequence (Seq)
 import Data.String (IsString(..))
 import Data.Text (Text)
 import Language.GraphQL.AST (Alias, Name, TypeCondition)
 
--- | GraphQL document is a non-empty list of operations.
-type Document = NonEmpty Operation
-
 -- | GraphQL has 3 operation types: queries, mutations and subscribtions.
 --
 -- Currently only queries and mutations are supported.

src/Language/GraphQL/Execute.hs

@@ -9,42 +9,42 @@ module Language.GraphQL.Execute
 
 import qualified Data.Aeson as Aeson
 import Data.Foldable (find)
+import qualified Data.HashMap.Strict as HashMap
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.Text (Text)
 import qualified Data.Text as Text
 import Language.GraphQL.AST.Document
 import qualified Language.GraphQL.AST.Core as AST.Core
+import Language.GraphQL.Execute.Coerce
 import qualified Language.GraphQL.Execute.Transform as Transform
 import Language.GraphQL.Error
 import qualified Language.GraphQL.Schema as Schema
-import Language.GraphQL.Type.Definition
+import qualified Language.GraphQL.Type.Definition as Definition
 import Language.GraphQL.Type.Schema
 
 -- | Query error types.
 data QueryError
     = OperationNotFound Text
     | OperationNameRequired
+    | CoercionError
 
 queryError :: QueryError -> Text
 queryError (OperationNotFound operationName) = Text.unwords
     ["Operation", operationName, "couldn't be found in the document."]
 queryError OperationNameRequired = "Missing operation name."
+queryError CoercionError = "Coercion error."
 
 -- | The substitution is applied to the document, and the resolvers are applied
 -- to the resulting fields.
 --
 -- Returns the result of the query against the schema wrapped in a /data/
 -- field, or errors wrapped in an /errors/ field.
-execute :: Monad m
+execute :: (Monad m, VariableValue a)
     => Schema m -- ^ Resolvers.
-    -> Schema.Subs -- ^ Variable substitution function.
+    -> HashMap.HashMap Name a -- ^ Variable substitution function.
     -> Document -- @GraphQL@ document.
     -> m Aeson.Value
-execute schema subs doc =
+execute schema = document schema Nothing
-    maybe transformError (document schema Nothing)
-        $ Transform.document subs doc
-  where
-    transformError = return $ singleError "Schema transformation error."
 
 -- | 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
@@ -52,41 +52,105 @@ execute schema subs doc =
 --
 -- Returns the result of the query against the schema wrapped in a /data/
 -- field, or errors wrapped in an /errors/ field.
-executeWithName :: Monad m
+executeWithName :: (Monad m, VariableValue a)
     => Schema m -- ^ Resolvers
     -> Text -- ^ Operation name.
-    -> Schema.Subs -- ^ Variable substitution function.
+    -> HashMap.HashMap Name a -- ^ Variable substitution function.
     -> Document -- ^ @GraphQL@ Document.
     -> m Aeson.Value
-executeWithName schema operationName subs doc =
+executeWithName schema operationName = document schema (Just operationName)
-    maybe transformError (document schema $ Just operationName)
-        $ Transform.document subs doc
-  where
-    transformError = return $ singleError "Schema transformation error."
 
 getOperation
     :: Maybe Text
-    -> AST.Core.Document
+    -> Transform.Document
-    -> Either QueryError AST.Core.Operation
+    -> Either QueryError Transform.OperationDefinition
-getOperation Nothing (operation' :| []) = pure operation'
+getOperation Nothing (Transform.Document (operation' :| []) _) = pure operation'
 getOperation Nothing _ = Left OperationNameRequired
-getOperation (Just operationName) document'
+getOperation (Just operationName) (Transform.Document operations _)
-    | Just operation' <- find matchingName document' = pure operation'
+    | Just operation' <- find matchingName operations = pure operation'
     | otherwise = Left $ OperationNotFound operationName
   where
-    matchingName (AST.Core.Query (Just name') _) = operationName == name'
+    matchingName (Transform.OperationDefinition _ name _ _ _) =
-    matchingName (AST.Core.Mutation (Just name') _) = operationName == name'
+        name == Just operationName
-    matchingName _ = False
 
-document :: Monad m
+lookupInputType
+    :: Type
+    -> HashMap.HashMap Name (Definition.TypeDefinition m)
+    -> Maybe Definition.InputType
+lookupInputType (TypeNamed name) types =
+    case HashMap.lookup name types of
+        Just (Definition.ScalarTypeDefinition scalarType) ->
+            Just $ Definition.ScalarInputType scalarType
+        Just (Definition.EnumTypeDefinition enumType) ->
+            Just $ Definition.EnumInputType enumType
+        Just (Definition.InputObjectTypeDefinition objectType) ->
+            Just $ Definition.ObjectInputType objectType
+        _ -> Nothing
+lookupInputType (TypeList list) types
+    = Definition.ListInputType
+    <$> lookupInputType list types
+lookupInputType (TypeNonNull (NonNullTypeNamed nonNull)) types  =
+    case HashMap.lookup nonNull types of
+        Just (Definition.ScalarTypeDefinition scalarType) ->
+            Just $ Definition.NonNullScalarInputType scalarType
+        Just (Definition.EnumTypeDefinition enumType) ->
+            Just $ Definition.NonNullEnumInputType enumType
+        Just (Definition.InputObjectTypeDefinition objectType) ->
+            Just $ Definition.NonNullObjectInputType objectType
+        _ -> Nothing
+lookupInputType (TypeNonNull (NonNullTypeList nonNull)) types
+    = Definition.NonNullListInputType
+    <$> lookupInputType nonNull types
+
+coerceVariableValues :: (Monad m, VariableValue a)
+    => Schema m
+    -> Transform.OperationDefinition
+    -> HashMap.HashMap Name a
+    -> Either QueryError Schema.Subs
+coerceVariableValues schema (Transform.OperationDefinition _ _ variables _ _) values =
+    let referencedTypes = collectReferencedTypes schema
+     in maybe (Left CoercionError) Right
+        $ foldr (coerceValue referencedTypes) (Just HashMap.empty) variables
+  where
+    coerceValue referencedTypes variableDefinition coercedValues = do
+        let VariableDefinition variableName variableTypeName _defaultValue =
+                variableDefinition
+        variableType <- lookupInputType variableTypeName referencedTypes
+        value <- HashMap.lookup variableName values
+        coercedValue <- coerceVariableValue variableType value
+        HashMap.insert variableName coercedValue <$> coercedValues
+
+executeRequest :: (Monad m, VariableValue a)
     => Schema m
     -> Maybe Text
-    -> AST.Core.Document
+    -> HashMap.HashMap Name a
+    -> Transform.Document
+    -> Either QueryError (Transform.OperationDefinition, Schema.Subs)
+executeRequest schema operationName subs document' = do
+    operation' <- getOperation operationName document'
+    coercedValues <- coerceVariableValues schema operation' subs
+    pure (operation', coercedValues)
+
+document :: (Monad m, VariableValue a)
+    => Schema m
+    -> Maybe Text
+    -> HashMap.HashMap Name a
+    -> Document
     -> m Aeson.Value
-document schema operationName document' =
+document schema operationName subs document' =
-    case getOperation operationName document' of
+    case Transform.document document' of
+        Just transformed -> executeRequest' transformed
+        Nothing -> pure $ singleError
+            "The document doesn't contain any executable operations."
+  where
+    transformOperation fragmentTable operation' subs' =
+        case Transform.operation fragmentTable subs' operation' of
+            Just operationResult -> operation schema operationResult
+            Nothing -> pure $ singleError "Schema transformation error."
+    executeRequest' transformed@(Transform.Document _ fragmentTable) =
+        case executeRequest schema operationName subs transformed of
+            Right (operation', subs') -> transformOperation fragmentTable operation' subs'
             Left error' -> pure $ singleError $ queryError error'
-        Right operation' -> operation schema operation'
 
 operation :: Monad m
     => Schema m
@@ -96,7 +160,8 @@ operation = schemaOperation
   where
     resolve queryFields = runCollectErrs
         . flip Schema.resolve queryFields
-        . fields
+        . fmap getResolver
+        . Definition.fields
     lookupError = pure
         $ singleError "Root operation type couldn't be found in the schema."
     schemaOperation Schema {query} (AST.Core.Query _ fields') =
@@ -105,3 +170,4 @@ operation = schemaOperation
         resolve fields' mutation
     schemaOperation Schema {mutation = Nothing} (AST.Core.Mutation _ _) =
         lookupError
+    getResolver (Definition.Field _ _ _ resolver) = resolver

src/Language/GraphQL/Execute/Coerce.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Types and functions used for input and result coercion.
+module Language.GraphQL.Execute.Coerce
+    ( VariableValue(..)
+    ) where
+
+import qualified Data.Aeson as Aeson
+import qualified Data.HashMap.Strict as HashMap
+import Data.Scientific (toBoundedInteger, toRealFloat)
+import Language.GraphQL.AST.Core
+import Language.GraphQL.Type.Definition
+
+-- | Since variables are passed separately from the query, in an independent
+-- format, they should be first coerced to the internal representation used by
+-- this implementation.
+class VariableValue a where
+    -- | Only a basic, format-specific, coercion must be done here. Type
+    -- correctness or nullability shouldn't be validated here, they will be
+    -- validated later. The type information is provided only as a hint.
+    --
+    -- For example @GraphQL@ prohibits the coercion from a 't:Float' to an
+    -- 't:Int', but @JSON@ doesn't have integers, so whole numbers should be
+    -- coerced to 't:Int` when receiving variables as a JSON object. The same
+    -- holds for 't:Enum'. There are formats that support enumerations, @JSON@
+    -- doesn't, so the type information is given and 'coerceVariableValue' can
+    -- check that an 't:Enum' is expected and treat the given value
+    -- appropriately. Even checking whether this value is a proper member of the
+    -- corresponding 't:Enum' type isn't required here, since this can be
+    -- checked independently.
+    --
+    -- Another example is an @ID@. @GraphQL@ explicitly allows to coerce
+    -- integers and strings to @ID@s, so if an @ID@ is received as an integer,
+    -- it can be left as is and will be coerced later.
+    --
+    -- If a value cannot be coerced without losing information, 'Nothing' should
+    -- be returned, the coercion will fail then and the query won't be executed.
+    coerceVariableValue
+        :: InputType -- ^ Expected type (variable type given in the query).
+        -> a -- ^ Variable value being coerced.
+        -> Maybe Value -- ^ Coerced value on success, 'Nothing' otherwise.
+
+instance VariableValue Aeson.Value where
+    coerceVariableValue _ Aeson.Null = Just Null
+    coerceVariableValue (ScalarInputTypeDefinition scalarType) value
+        | (Aeson.String stringValue) <- value = Just $ String stringValue
+        | (Aeson.Bool booleanValue) <- value = Just $ Boolean booleanValue
+        | (Aeson.Number numberValue) <- value
+        , (ScalarType "Float" _) <- scalarType =
+            Just $ Float $ toRealFloat numberValue
+        | (Aeson.Number numberValue) <- value = -- ID or Int
+            Int <$> toBoundedInteger numberValue
+    coerceVariableValue (EnumInputTypeDefinition _) (Aeson.String stringValue) =
+        Just $ Enum stringValue
+    coerceVariableValue (ObjectInputTypeDefinition objectType) value
+        | (Aeson.Object objectValue) <- value = do
+            let (InputObjectType _ _ inputFields) = objectType
+            (newObjectValue, resultMap) <- foldWithKey objectValue inputFields
+            if HashMap.null newObjectValue
+                then Just $ Object resultMap
+                else Nothing
+      where
+        foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues
+            $ Just (objectValue, HashMap.empty)
+        matchFieldValues _ _ Nothing = Nothing
+        matchFieldValues fieldName inputField (Just (objectValue, resultMap)) =
+            let (InputField _ fieldType _) = inputField
+                insert = flip (HashMap.insert fieldName) resultMap
+                newObjectValue = HashMap.delete fieldName objectValue
+             in case HashMap.lookup fieldName objectValue of
+                    Just variableValue -> do
+                        coerced <- coerceVariableValue fieldType variableValue
+                        pure (newObjectValue, insert coerced)
+                    Nothing -> Just (objectValue, resultMap)
+    coerceVariableValue (ListInputTypeDefinition listType) value
+        | (Aeson.Array arrayValue) <- value = List
+            <$> foldr foldVector (Just []) arrayValue
+        | otherwise = coerceVariableValue listType value
+      where
+        foldVector _ Nothing = Nothing
+        foldVector variableValue (Just list) = do
+            coerced <- coerceVariableValue listType variableValue
+            pure $ coerced : list 
+    coerceVariableValue _ _ = Nothing

src/Language/GraphQL/Execute/Transform.hs

@@ -1,25 +1,28 @@
 {-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TupleSections #-}
 
 -- | After the document is parsed, before getting executed the AST is
 --   transformed into a similar, simpler AST. This module is responsible for
 --   this transformation.
 module Language.GraphQL.Execute.Transform
-    ( document
+    ( Document(..)
+    , OperationDefinition(..)
+    , document
+    , operation
     ) where
 
-import Control.Arrow (first)
 import Control.Monad (foldM, unless)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
 import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
+import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as NonEmpty
 import Data.Sequence (Seq, (<|), (><))
 import qualified Language.GraphQL.AST as Full
 import qualified Language.GraphQL.AST.Core as Core
-import Language.GraphQL.AST.Document (Definition(..), Document)
 import qualified Language.GraphQL.Schema as Schema
 import qualified Language.GraphQL.Type.Directive as Directive
 
@@ -34,36 +37,56 @@ type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a
 liftJust :: forall a. a -> TransformT a
 liftJust = lift . lift . Just
 
+-- | GraphQL document is a non-empty list of operations.
+data Document = Document
+    (NonEmpty OperationDefinition)
+    (HashMap Full.Name Full.FragmentDefinition)
+
+data OperationDefinition = OperationDefinition
+    Full.OperationType
+    (Maybe Full.Name)
+    [Full.VariableDefinition]
+    [Full.Directive]
+    Full.SelectionSet
+
 -- | Rewrites the original syntax tree into an intermediate representation used
 -- for query execution.
-document :: Schema.Subs -> Document -> Maybe Core.Document
+document :: Full.Document -> Maybe Document
-document subs document' =
+document ast =
-    flip runReaderT subs
+    let (operations, fragmentTable) = foldr defragment ([], HashMap.empty) ast
-        $ evalStateT (collectFragments >> operations operationDefinitions)
+     in Document <$> NonEmpty.nonEmpty operations <*> pure fragmentTable
-        $ Replacement HashMap.empty fragmentTable
   where
-    (fragmentTable, operationDefinitions) = foldr defragment mempty document'
+    defragment definition (operations, fragments')
-    defragment (ExecutableDefinition (Full.DefinitionOperation definition)) acc =
+        | (Full.ExecutableDefinition executable) <- definition
-        (definition :) <$> acc
+        , (Full.DefinitionOperation operation') <- executable =
-    defragment (ExecutableDefinition (Full.DefinitionFragment definition)) acc =
+            (transform operation' : operations, fragments')
-        let (Full.FragmentDefinition name _ _ _) = definition
+        | (Full.ExecutableDefinition executable) <- definition
-         in first (HashMap.insert name definition) acc
+        , (Full.DefinitionFragment fragment) <- executable
+        , (Full.FragmentDefinition name _ _ _) <- fragment =
+            (operations, HashMap.insert name fragment fragments')
     defragment _ acc = acc
+    transform = \case
+        Full.OperationDefinition type' name variables directives' selections ->
+            OperationDefinition type' name variables directives' selections
+        Full.SelectionSet selectionSet ->
+            OperationDefinition Full.Query Nothing mempty mempty selectionSet
 
 -- * Operation
 
-operations :: [Full.OperationDefinition] -> TransformT Core.Document
+operation
-operations operations' = do
+    :: HashMap Full.Name Full.FragmentDefinition
-    coreOperations <- traverse operation operations'
+    -> Schema.Subs
-    lift . lift $ NonEmpty.nonEmpty coreOperations
+    -> OperationDefinition
-
+    -> Maybe Core.Operation
-operation :: Full.OperationDefinition -> TransformT Core.Operation
+operation fragmentTable subs operationDefinition = flip runReaderT subs
-operation (Full.SelectionSet sels)
+    $ evalStateT (collectFragments >> transform operationDefinition)
-    = operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels
+    $ Replacement HashMap.empty fragmentTable
-operation (Full.OperationDefinition Full.Query name _vars _dirs sels)
+  where
-    = Core.Query name <$> appendSelection sels
+    transform :: OperationDefinition -> TransformT Core.Operation
-operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels)
+    transform (OperationDefinition Full.Query name _ _ sels) =
-    = Core.Mutation name <$> appendSelection sels
+        Core.Query name <$> appendSelection sels
+    transform (OperationDefinition Full.Mutation name _ _ sels) =
+        Core.Mutation name <$> appendSelection sels
 
 -- * Selection
 

src/Language/GraphQL/Schema.hs

@@ -3,8 +3,7 @@
 -- | This module provides a representation of a @GraphQL@ Schema in addition to
 -- functions for defining and manipulating schemas.
 module Language.GraphQL.Schema
-    ( FieldResolver(..)
+    ( Resolver(..)
-    , Resolver(..)
     , Subs
     , object
     , resolve
@@ -31,21 +30,18 @@ import qualified Data.Text as T
 import Language.GraphQL.AST.Core
 import Language.GraphQL.Error
 import Language.GraphQL.Trans
+import qualified Language.GraphQL.Type.Definition as Definition
 import qualified Language.GraphQL.Type as Type
 
 -- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
 --   information (if an error has occurred). @m@ is an arbitrary monad, usually
 --   'IO'.
-data Resolver m = Resolver Name (FieldResolver m)
+data Resolver m = Resolver Name (Definition.FieldResolver m)
-
-data FieldResolver m
-    = ValueResolver (ActionT m Aeson.Value)
-    | NestingResolver (ActionT m (Type.Wrapping (HashMap Name (FieldResolver m))))
 
 -- | Converts resolvers to a map.
 resolversToMap :: (Foldable f, Functor f)
     => f (Resolver m)
-    -> HashMap Text (FieldResolver m)
+    -> HashMap Text (Definition.FieldResolver m)
 resolversToMap = HashMap.fromList . toList . fmap toKV
   where
     toKV (Resolver name r) = (name, r)
@@ -57,7 +53,7 @@ type Subs = HashMap Name Value
 -- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
 object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m
 object name = Resolver name
-    . NestingResolver
+    . Definition.NestingResolver
     . fmap (Type.Named . resolversToMap)
 
 -- | Like 'object' but can be null or a list of objects.
@@ -66,19 +62,19 @@ wrappedObject :: Monad m
     -> ActionT m (Type.Wrapping [Resolver m])
     -> Resolver m
 wrappedObject name = Resolver name
-    . NestingResolver
+    . Definition.NestingResolver
     . (fmap . fmap) resolversToMap
 
 -- | A scalar represents a primitive value, like a string or an integer.
 scalar :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
-scalar name = Resolver name . ValueResolver . fmap Aeson.toJSON
+scalar name = Resolver name . Definition.ValueResolver . fmap Aeson.toJSON
 
 -- | Like 'scalar' but can be null or a list of scalars.
 wrappedScalar :: (Monad m, Aeson.ToJSON a)
     => Name
     -> ActionT m (Type.Wrapping a)
     -> Resolver m
-wrappedScalar name = Resolver name . ValueResolver . fmap Aeson.toJSON
+wrappedScalar name = Resolver name . Definition.ValueResolver . fmap Aeson.toJSON
 
 resolveFieldValue :: Monad m => Field -> ActionT m a -> m (Either Text a)
 resolveFieldValue field@(Field _ _ args _) =
@@ -91,11 +87,14 @@ convert Type.Null = Aeson.Null
 convert (Type.Named value) = value
 convert (Type.List value) = Aeson.toJSON value
 
-withField :: Monad m => Field -> FieldResolver m -> CollectErrsT m Aeson.Object
+withField :: Monad m
-withField field (ValueResolver resolver) = do
+    => Field
+    -> Definition.FieldResolver m
+    -> CollectErrsT m Aeson.Object
+withField field (Definition.ValueResolver resolver) = do
     answer <- lift $ resolveFieldValue field resolver
     either (errmsg field) (pure . HashMap.singleton (aliasOrName field)) answer
-withField field@(Field _ _ _ seqSelection) (NestingResolver resolver) = do
+withField field@(Field _ _ _ seqSelection) (Definition.NestingResolver resolver) = do
     answer <- lift $ resolveFieldValue field resolver
     case answer of
         Right result -> do
@@ -112,7 +111,7 @@ errmsg field errorMessage = do
 --   'Resolver' to each 'Field'. Resolves into a value containing the
 --   resolved 'Field', or a null value and error information.
 resolve :: Monad m
-    => HashMap Text (FieldResolver m)
+    => HashMap Text (Definition.FieldResolver m)
     -> Seq Selection
     -> CollectErrsT m Aeson.Value
 resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
@@ -122,7 +121,7 @@ resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
         | (Just resolver) <- lookupResolver name = withField fld resolver
         | otherwise = errmsg fld $ T.unwords ["field", name, "not resolved."]
     tryResolvers (SelectionFragment (Fragment typeCondition selections'))
-        | Just (ValueResolver resolver) <- lookupResolver "__typename" = do
+        | Just (Definition.ValueResolver resolver) <- lookupResolver "__typename" = do
             let fakeField = Field Nothing "__typename" mempty mempty
             that <- lift $ resolveFieldValue fakeField resolver
             if Right (Aeson.String typeCondition) == that

src/Language/GraphQL/Type/Definition.hs

@@ -1,18 +1,256 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-- | Types representing GraphQL type system.
 module Language.GraphQL.Type.Definition
-    ( ObjectType(..)
+    ( Argument(..)
+    , EnumType(..)
+    , Field(..)
+    , FieldResolver(..)
+    , InputField(..)
+    , InputObjectType(..)
+    , InputType(..)
+    , ObjectType(..)
+    , OutputType(..)
+    , ScalarType(..)
+    , TypeDefinition(..)
+    , pattern EnumInputTypeDefinition
+    , pattern ListInputTypeDefinition
+    , pattern ObjectInputTypeDefinition
+    , pattern ScalarInputTypeDefinition
+    , pattern EnumOutputTypeDefinition
+    , pattern ListOutputTypeDefinition
+    , pattern ObjectOutputTypeDefinition
+    , pattern ScalarOutputTypeDefinition
+    , boolean
+    , float
+    , id
+    , int
+    , string
     ) where
 
+import qualified Data.Aeson as Aeson
 import Data.HashMap.Strict (HashMap)
+import Data.Set (Set)
 import Data.Text (Text)
-import Language.GraphQL.Schema
+import Language.GraphQL.AST.Core (Name, Value)
+import Language.GraphQL.Trans
+import qualified Language.GraphQL.Type as Type
+import Prelude hiding (id)
 
-type Fields m = HashMap Text (FieldResolver m)
+-- | Object type definition.
-
--- | Object Type Definition.
 --
 --   Almost all of the GraphQL types you define will be object types. Object
 --   types have a name, but most importantly describe their fields.
 data ObjectType m = ObjectType
     { name :: Text
-    , fields :: Fields m
+    , fields :: HashMap Name (Field m)
     }
+
+-- | Output object field definition.
+data Field m = Field
+    (Maybe Text) (OutputType m) (HashMap Name Argument) (FieldResolver m)
+
+-- | Resolving a field can result in a leaf value or an object, which is
+-- represented as a list of nested resolvers, used to resolve the fields of that
+-- object.
+data FieldResolver m
+    = ValueResolver (ActionT m Aeson.Value)
+    | NestingResolver (ActionT m (Type.Wrapping (HashMap Name (FieldResolver m))))
+
+-- | Field argument definition.
+data Argument = Argument (Maybe Text) InputType (Maybe Value)
+
+-- | Scalar type definition.
+--
+-- The leaf values of any request and input values to arguments are Scalars (or
+-- Enums) .
+data ScalarType = ScalarType Name (Maybe Text)
+
+-- | Enum type definition.
+--
+-- Some leaf values of requests and input values are Enums. GraphQL serializes
+-- Enum values as strings, however internally Enums can be represented by any
+-- kind of type, often integers.
+data EnumType = EnumType Name (Maybe Text) (Set Text)
+
+-- | Single field of an 'InputObjectType'.
+data InputField = InputField (Maybe Text) InputType (Maybe Value)
+
+-- | Input object type definition.
+--
+-- An input object defines a structured collection of fields which may be
+-- supplied to a field argument.
+data InputObjectType = InputObjectType
+    Name (Maybe Text) (HashMap Name InputField)
+
+-- | These types may be used as input types for arguments and directives.
+data InputType
+    = ScalarInputType ScalarType
+    | EnumInputType EnumType
+    | ObjectInputType InputObjectType
+    | ListInputType InputType
+    | NonNullScalarInputType ScalarType
+    | NonNullEnumInputType EnumType
+    | NonNullObjectInputType InputObjectType
+    | NonNullListInputType InputType
+
+-- | These types may be used as output types as the result of fields.
+data OutputType m
+    = ScalarOutputType ScalarType
+    | EnumOutputType EnumType
+    | ObjectOutputType (ObjectType m)
+    | ListOutputType (OutputType m)
+    | NonNullScalarOutputType ScalarType
+    | NonNullEnumOutputType EnumType
+    | NonNullObjectOutputType (ObjectType m)
+    | NonNullListOutputType (OutputType m)
+
+-- | These are all of the possible kinds of types.
+data TypeDefinition m
+    = ScalarTypeDefinition ScalarType
+    | EnumTypeDefinition EnumType
+    | ObjectTypeDefinition (ObjectType m)
+    | InputObjectTypeDefinition InputObjectType
+
+-- | The @String@ scalar type represents textual data, represented as UTF-8
+-- character sequences. The String type is most often used by GraphQL to
+-- represent free-form human-readable text.
+string :: ScalarType
+string = ScalarType "String" (Just description)
+  where
+    description =
+        "The `String` scalar type represents textual data, represented as \
+        \UTF-8 character sequences. The String type is most often used by \
+        \GraphQL to represent free-form human-readable text."
+
+-- | The @Boolean@ scalar type represents @true@ or @false@.
+boolean :: ScalarType
+boolean = ScalarType "Boolean" (Just description)
+  where
+    description = "The `Boolean` scalar type represents `true` or `false`."
+
+-- | The @Int@ scalar type represents non-fractional signed whole numeric
+-- values. Int can represent values between \(-2^{31}\) and \(2^{31 - 1}\).
+int :: ScalarType
+int = ScalarType "Int" (Just description)
+  where
+    description =
+        "The `Int` scalar type represents non-fractional signed whole numeric \
+        \values. Int can represent values between -(2^31) and 2^31 - 1."
+
+-- | The @Float@ scalar type represents signed double-precision fractional
+-- values as specified by
+-- [IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point).
+float :: ScalarType
+float = ScalarType "Float" (Just description)
+  where
+    description =
+        "The `Float` scalar type represents signed double-precision fractional \
+        \values as specified by \
+        \[IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point)."
+
+-- | The @ID@ scalar type represents a unique identifier, often used to refetch
+-- an object or as key for a cache. The ID type appears in a JSON response as a
+-- String; however, it is not intended to be human-readable. When expected as an
+-- input type, any string (such as @"4"@) or integer (such as @4@) input value
+-- will be accepted as an ID.
+id :: ScalarType
+id = ScalarType "ID" (Just description)
+  where
+    description =
+        "The `ID` scalar type represents a unique identifier, often used to \
+        \refetch an object or as key for a cache. The ID type appears in a \
+        \JSON response as a String; however, it is not intended to be \
+        \human-readable. When expected as an input type, any string (such as \
+        \`\"4\"`) or integer (such as `4`) input value will be accepted as an ID."
+
+-- | Matches either 'ScalarInputType' or 'NonNullScalarInputType'.
+pattern ScalarInputTypeDefinition :: ScalarType -> InputType
+pattern ScalarInputTypeDefinition scalarType <-
+    (isScalarInputType -> Just scalarType)
+
+-- | Matches either 'EnumInputType' or 'NonNullEnumInputType'.
+pattern EnumInputTypeDefinition :: EnumType -> InputType
+pattern EnumInputTypeDefinition enumType <-
+    (isEnumInputType -> Just enumType)
+
+-- | Matches either 'ObjectInputType' or 'NonNullObjectInputType'.
+pattern ObjectInputTypeDefinition :: InputObjectType -> InputType
+pattern ObjectInputTypeDefinition objectType <-
+    (isObjectInputType -> Just objectType)
+
+-- | Matches either 'ListInputType' or 'NonNullListInputType'.
+pattern ListInputTypeDefinition :: InputType -> InputType
+pattern ListInputTypeDefinition listType <-
+    (isListInputType -> Just listType)
+
+{-# COMPLETE EnumInputTypeDefinition
+    , ListInputTypeDefinition
+    , ObjectInputTypeDefinition
+    , ScalarInputTypeDefinition
+    #-}
+
+pattern ScalarOutputTypeDefinition :: forall m. ScalarType -> OutputType m
+pattern ScalarOutputTypeDefinition scalarType <-
+    (isScalarOutputType -> Just scalarType)
+
+pattern EnumOutputTypeDefinition :: forall m. EnumType -> OutputType m
+pattern EnumOutputTypeDefinition enumType <-
+    (isEnumOutputType -> Just enumType)
+
+pattern ObjectOutputTypeDefinition :: forall m. ObjectType m -> OutputType m
+pattern ObjectOutputTypeDefinition objectType <-
+    (isObjectOutputType -> Just objectType)
+
+pattern ListOutputTypeDefinition :: forall m. OutputType m -> OutputType m
+pattern ListOutputTypeDefinition listType <-
+    (isListOutputType -> Just listType)
+
+{-# COMPLETE ScalarOutputTypeDefinition
+    , EnumOutputTypeDefinition
+    , ObjectOutputTypeDefinition
+    , ListOutputTypeDefinition
+    #-}
+
+isScalarInputType :: InputType -> Maybe ScalarType
+isScalarInputType (ScalarInputType inputType) = Just inputType
+isScalarInputType (NonNullScalarInputType inputType) = Just inputType
+isScalarInputType _ = Nothing
+
+isObjectInputType :: InputType -> Maybe InputObjectType
+isObjectInputType (ObjectInputType inputType) = Just inputType
+isObjectInputType (NonNullObjectInputType inputType) = Just inputType
+isObjectInputType _ = Nothing
+
+isEnumInputType :: InputType -> Maybe EnumType
+isEnumInputType (EnumInputType inputType) = Just inputType
+isEnumInputType (NonNullEnumInputType inputType) = Just inputType
+isEnumInputType _ = Nothing
+
+isListInputType :: InputType -> Maybe InputType
+isListInputType (ListInputType inputType) = Just inputType
+isListInputType (NonNullListInputType inputType) = Just inputType
+isListInputType _ = Nothing
+
+isScalarOutputType :: forall m. OutputType m -> Maybe ScalarType
+isScalarOutputType (ScalarOutputType outputType) = Just outputType
+isScalarOutputType (NonNullScalarOutputType outputType) = Just outputType
+isScalarOutputType _ = Nothing
+
+isObjectOutputType :: forall m. OutputType m -> Maybe (ObjectType m)
+isObjectOutputType (ObjectOutputType outputType) = Just outputType
+isObjectOutputType (NonNullObjectOutputType outputType) = Just outputType
+isObjectOutputType _ = Nothing
+
+isEnumOutputType :: forall m. OutputType m -> Maybe EnumType
+isEnumOutputType (EnumOutputType outputType) = Just outputType
+isEnumOutputType (NonNullEnumOutputType outputType) = Just outputType
+isEnumOutputType _ = Nothing
+
+isListOutputType :: forall m. OutputType m -> Maybe (OutputType m)
+isListOutputType (ListOutputType outputType) = Just outputType
+isListOutputType (NonNullListOutputType outputType) = Just outputType
+isListOutputType _ = Nothing

src/Language/GraphQL/Type/Schema.hs

@@ -1,11 +1,68 @@
+{-# LANGUAGE ExplicitForAll #-}
+
+-- | Schema Definition.
 module Language.GraphQL.Type.Schema
     ( Schema(..)
+    , collectReferencedTypes
     ) where
 
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Language.GraphQL.AST.Core (Name)
 import Language.GraphQL.Type.Definition
 
--- | Schema Definition
+-- | A Schema is created by supplying the root types of each type of operation,
+--   query and mutation (optional). A schema definition is then supplied to the
+--   validator and executor.
+--
+--   __Note:__ When the schema is constructed, by default only the types that
+--   are reachable by traversing the root types are included, other types must
+--   be explicitly referenced.
 data Schema m = Schema
     { query :: ObjectType m
     , mutation :: Maybe (ObjectType m)
     }
+
+-- | Traverses the schema and finds all referenced types.
+collectReferencedTypes :: forall m. Schema m -> HashMap Name (TypeDefinition m)
+collectReferencedTypes schema =
+    let queryTypes = traverseObjectType (query schema) HashMap.empty
+     in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema
+  where
+    collect traverser typeName element foundTypes =
+        let newMap = HashMap.insert typeName element foundTypes
+         in maybe (traverser newMap) (const foundTypes)
+            $ HashMap.lookup typeName foundTypes
+    visitFields (Field _ outputType arguments _) foundTypes
+        = traverseOutputType outputType
+        $ foldr visitArguments foundTypes arguments
+    visitArguments (Argument _ inputType _) = traverseInputType inputType
+    visitInputFields (InputField _ inputType _) = traverseInputType inputType
+    traverseInputType (ObjectInputTypeDefinition objectType) =
+        let (InputObjectType typeName _ inputFields) = objectType
+            element = InputObjectTypeDefinition objectType
+            traverser = flip (foldr visitInputFields) inputFields
+         in collect traverser typeName element
+    traverseInputType (ListInputTypeDefinition listType) =
+        traverseInputType listType
+    traverseInputType (ScalarInputTypeDefinition scalarType) =
+        let (ScalarType typeName _) = scalarType
+         in collect Prelude.id typeName (ScalarTypeDefinition scalarType)
+    traverseInputType (EnumInputTypeDefinition enumType) =
+        let (EnumType typeName _ _) = enumType
+         in collect Prelude.id typeName (EnumTypeDefinition enumType)
+    traverseOutputType (ObjectOutputTypeDefinition objectType) =
+        traverseObjectType objectType
+    traverseOutputType (ListOutputTypeDefinition listType) =
+        traverseOutputType listType
+    traverseOutputType (ScalarOutputTypeDefinition scalarType) =
+        let (ScalarType typeName _) = scalarType
+         in collect Prelude.id typeName (ScalarTypeDefinition scalarType)
+    traverseOutputType (EnumOutputTypeDefinition enumType) =
+        let (EnumType typeName _ _) = enumType
+         in collect Prelude.id typeName (EnumTypeDefinition enumType)
+    traverseObjectType objectType foundTypes =
+        let (ObjectType typeName objectFields) = objectType
+            element = ObjectTypeDefinition objectType
+            traverser = flip (foldr visitFields) objectFields
+         in collect traverser typeName element foundTypes

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-15.12
+resolver: lts-15.13
 
 packages:
 - .

tests/Language/GraphQL/Execute/CoerceSpec.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.GraphQL.Execute.CoerceSpec
+    ( spec
+    ) where
+
+import Data.Aeson as Aeson ((.=))
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
+import qualified Data.HashMap.Strict as HashMap
+import Data.Maybe (isNothing)
+import Data.Scientific (scientific)
+import Language.GraphQL.AST.Core
+import Language.GraphQL.Execute.Coerce
+import Language.GraphQL.Type.Definition
+import Prelude hiding (id)
+import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)
+
+singletonInputObject :: InputType
+singletonInputObject = ObjectInputType type'
+  where
+    type' = InputObjectType "ObjectName" Nothing inputFields
+    inputFields = HashMap.singleton "field" field
+    field = InputField Nothing (ScalarInputType string) Nothing
+
+spec :: Spec
+spec =
+    describe "ToGraphQL Aeson" $ do
+        it "coerces strings" $
+            let expected = Just (String "asdf")
+                actual = coerceVariableValue
+                    (ScalarInputType string) (Aeson.String "asdf")
+             in actual `shouldBe` expected
+        it "coerces non-null strings" $
+            let expected = Just (String "asdf")
+                actual = coerceVariableValue
+                    (NonNullScalarInputType string) (Aeson.String "asdf")
+             in actual `shouldBe` expected
+        it "coerces booleans" $
+            let expected = Just (Boolean True)
+                actual = coerceVariableValue
+                    (ScalarInputType boolean) (Aeson.Bool True)
+             in actual `shouldBe` expected
+        it "coerces zero to an integer" $
+            let expected = Just (Int 0)
+                actual = coerceVariableValue
+                    (ScalarInputType int) (Aeson.Number 0)
+             in actual `shouldBe` expected
+        it "rejects fractional if an integer is expected" $
+            let actual = coerceVariableValue
+                    (ScalarInputType int) (Aeson.Number $ scientific 14 (-1))
+             in actual `shouldSatisfy` isNothing
+        it "coerces float numbers" $
+            let expected = Just (Float 1.4)
+                actual = coerceVariableValue
+                    (ScalarInputType float) (Aeson.Number $ scientific 14 (-1))
+             in actual `shouldBe` expected
+        it "coerces IDs" $
+            let expected = Just (String "1234")
+                actual = coerceVariableValue
+                    (ScalarInputType id) (Aeson.String "1234")
+             in actual `shouldBe` expected
+        it "coerces input objects" $
+            let actual = coerceVariableValue singletonInputObject
+                    $ Aeson.object ["field" .= ("asdf" :: Aeson.Value)]
+                expected = Just $ Object $ HashMap.singleton "field" "asdf"
+             in actual `shouldBe` expected
+        it "skips the field if it is missing in the variables" $
+            let actual = coerceVariableValue
+                    singletonInputObject Aeson.emptyObject
+                expected = Just $ Object HashMap.empty
+             in actual `shouldBe` expected
+        it "fails if input object value contains extra fields" $
+            let actual = coerceVariableValue singletonInputObject
+                    $ Aeson.object variableFields
+                variableFields =
+                    [ "field" .= ("asdf" :: Aeson.Value)
+                    , "extra" .= ("qwer" :: Aeson.Value)
+                    ]
+             in actual `shouldSatisfy` isNothing
+        it "preserves null" $
+            let actual = coerceVariableValue (ScalarInputType id) Aeson.Null
+             in actual `shouldBe` Just Null
+        it "preserves list order" $
+            let list = Aeson.toJSONList ["asdf" :: Aeson.Value, "qwer"]
+                listType = (ListInputType $ ScalarInputType string)
+                actual = coerceVariableValue listType list
+                expected = Just $ List [String "asdf", String "qwer"]
+             in actual `shouldBe` expected

tests/Test/DirectiveSpec.hs

@@ -7,7 +7,6 @@ module Test.DirectiveSpec
 import Data.Aeson (Value(..), object, (.=))
 import qualified Data.HashMap.Strict as HashMap
 import Language.GraphQL
-import qualified Language.GraphQL.Schema as Schema
 import Language.GraphQL.Type.Definition
 import Language.GraphQL.Type.Schema (Schema(..))
 import Test.Hspec (Spec, describe, it, shouldBe)
@@ -16,11 +15,10 @@ import Text.RawString.QQ (r)
 experimentalResolver :: Schema IO
 experimentalResolver = Schema { query = queryType, mutation = Nothing }
   where
+    resolver = ValueResolver $ pure $ Number 5
     queryType = ObjectType "Query"
         $ HashMap.singleton "experimentalField"
-        $ Schema.ValueResolver
+        $ Field Nothing (ScalarOutputType int) mempty resolver
-        $ pure
-        $ Number 5
 
 emptyObject :: Value
 emptyObject = object

tests/Test/FragmentSpec.hs

@@ -6,7 +6,6 @@ module Test.FragmentSpec
 
 import Data.Aeson (Value(..), object, (.=))
 import qualified Data.HashMap.Strict as HashMap
-import Data.List.NonEmpty (NonEmpty(..))
 import Data.Text (Text)
 import Language.GraphQL
 import qualified Language.GraphQL.Schema as Schema
@@ -50,12 +49,28 @@ hasErrors :: Value -> Bool
 hasErrors (Object object') = HashMap.member "errors" object'
 hasErrors _ = True
 
-toSchema :: Schema.Resolver IO -> Schema IO
+shirtType :: ObjectType IO
-toSchema resolver = Schema { query = queryType, mutation = Nothing }
+shirtType = ObjectType "Shirt"
+    $ HashMap.singleton resolverName
+    $ Field Nothing (ScalarOutputType string) mempty resolve
   where
+    (Schema.Resolver resolverName resolve) = size
+
+hatType :: ObjectType IO
+hatType = ObjectType "Hat"
+    $ HashMap.singleton resolverName
+    $ Field Nothing (ScalarOutputType int) mempty resolve
+  where
+    (Schema.Resolver resolverName resolve) = circumference
+
+toSchema :: Schema.Resolver IO -> Schema IO
+toSchema (Schema.Resolver resolverName resolve) = Schema
+    { query = queryType, mutation = Nothing }
+  where
+    unionMember = if resolverName == "Hat" then hatType else shirtType
     queryType = ObjectType "Query"
-        $ Schema.resolversToMap
+        $ HashMap.singleton resolverName
-        $ resolver :| []
+        $ Field Nothing (ObjectOutputType unionMember) mempty resolve
 
 spec :: Spec
 spec = do

tests/Test/RootOperationSpec.hs

@@ -5,6 +5,7 @@ module Test.RootOperationSpec
     ) where
 
 import Data.Aeson ((.=), object)
+import qualified Data.HashMap.Strict as HashMap
 import Data.List.NonEmpty (NonEmpty(..))
 import Language.GraphQL
 import qualified Language.GraphQL.Schema as Schema
@@ -13,10 +14,18 @@ import Text.RawString.QQ (r)
 import Language.GraphQL.Type.Definition
 import Language.GraphQL.Type.Schema
 
+hatType :: ObjectType IO
+hatType = ObjectType "Hat"
+    $ HashMap.singleton resolverName
+    $ Field Nothing (ScalarOutputType int) mempty resolve
+  where
+    (Schema.Resolver resolverName resolve) =
+        Schema.scalar "circumference" $ pure (60 :: Int)
+
 schema :: Schema IO
 schema = Schema
-    (ObjectType "Query" queryResolvers)
+    (ObjectType "Query" hatField)
-    (Just $ ObjectType "Mutation" mutationResolvers)
+    (Just $ ObjectType "Mutation" incrementField)
   where
     queryResolvers = Schema.resolversToMap $ garment :| []
     mutationResolvers = Schema.resolversToMap $ increment :| []
@@ -25,6 +34,10 @@ schema = Schema
         ]
     increment = Schema.scalar "incrementCircumference"
         $ pure (61 :: Int)
+    incrementField = Field Nothing (ScalarOutputType int) mempty
+        <$> mutationResolvers
+    hatField = Field Nothing (ObjectOutputType hatType) mempty
+        <$> queryResolvers
 
 spec :: Spec
 spec =

tests/Test/StarWars/QuerySpec.hs

@@ -10,7 +10,6 @@ import Data.Functor.Identity (Identity(..))
 import qualified Data.HashMap.Strict as HashMap
 import Data.Text (Text)
 import Language.GraphQL
-import Language.GraphQL.Schema (Subs)
 import Text.RawString.QQ (r)
 import Test.Hspec.Expectations (Expectation, shouldBe)
 import Test.Hspec (Spec, describe, it)
@@ -360,6 +359,6 @@ spec = describe "Star Wars Query Tests" $ do
 testQuery :: Text -> Aeson.Value -> Expectation
 testQuery q expected = runIdentity (graphql schema q) `shouldBe` expected
 
-testQueryParams :: Subs -> Text -> Aeson.Value -> Expectation
+testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation
 testQueryParams f q expected =
     runIdentity (graphqlSubs schema f q) `shouldBe` expected

tests/Test/StarWars/Schema.hs

@@ -25,8 +25,8 @@ schema :: Schema Identity
 schema = Schema { query = queryType, mutation = Nothing }
   where
     queryType = ObjectType "Query"
-        $ Schema.resolversToMap
+        $ Field Nothing (ScalarOutputType string) mempty
-        $ hero :| [human, droid]
+        <$> Schema.resolversToMap (hero :| [human, droid])
 
 hero :: Schema.Resolver Identity
 hero = Schema.object "hero" $ do