Resolve abstract types

Objects that can be a part of an union or interface should return
__typename as string.

CHANGELOG.md

@@ -17,8 +17,8 @@ and this project adheres to
     * Invalid (recusrive or non-existing) fragments should be skipped.
 
 ### Changed
-- `Schema.Resolver` cannot return arbitrary JSON anymore, but only
+- `Schema.Resolver` was moved to `Type.Out`, it is a field and resolver function
-  `Type.Definition.Value`.
+  pair.
 - `AST.Core.Value` was moved into `Type.Definition`. These values are used only
   in the execution and type system, it is not a part of the parsing tree.
 - `Type` module is superseded by `Type.Out`. This module contains now only
@@ -46,6 +46,7 @@ and this project adheres to
 - `Schema.wrappedObject`, `Schema.object`, `Schema.resolversToMap`. There is no
   need in special functions to construct field resolvers anymore, resolvers are
   normal functions attached to the fields in the schema representation.
+- `Schema.resolve` is superseded by `Execute.Execution`.
 - `Error.runAppendErrs` isn't used anywhere.
 - `AST.Core`: `Document`, `Directive`, `Field`, `Fragment`, `Selection`, `Alias`
   `TypeCondition` were modified, moved into `Execute.Transform.Document` and

docs/tutorial/tutorial.lhs

@@ -42,7 +42,10 @@ First we build a GraphQL schema.
 > queryType :: ObjectType IO
 > queryType = ObjectType "Query" Nothing []
 >   $ HashMap.singleton "hello"
->   $ Field Nothing (Out.NamedScalarType string) mempty hello
+>   $ Out.Resolver helloField hello
+>
+> helloField :: Field IO
+> helloField = Field Nothing (Out.NamedScalarType string) mempty
 >
 > hello :: ActionT IO Value
 > hello = pure $ String "it's me"
@@ -77,7 +80,10 @@ For this example, we're going to be using time.
 > queryType2 :: ObjectType IO
 > queryType2 = ObjectType "Query" Nothing []
 >   $ HashMap.singleton "time"
->   $ Field Nothing (Out.NamedScalarType string) mempty time
+>   $ Out.Resolver timeField time
+>
+> timeField :: Field IO
+> timeField = Field Nothing (Out.NamedScalarType string) mempty
 >
 > time :: ActionT IO Value
 > time = do
@@ -140,8 +146,8 @@ Now that we have two resolvers, we can define a schema which uses them both.
 >
 > queryType3 :: ObjectType IO
 > queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList
->   [ ("hello", Field Nothing (Out.NamedScalarType string) mempty hello)
+>   [ ("hello", Out.Resolver helloField hello)
->   , ("time", Field Nothing (Out.NamedScalarType string) mempty time)
+>   , ("time", Out.Resolver timeField time)
 >   ]
 >
 > query3 :: Text

src/Language/GraphQL.hs

@@ -16,7 +16,7 @@ import Language.GraphQL.Type.Schema
 import Text.Megaparsec (parse)
 
 -- | If the text parses correctly as a @GraphQL@ query the query is
--- executed using the given 'Schema.Resolver's.
+-- executed using the given 'Schema'.
 graphql :: Monad m
     => Schema m -- ^ Resolvers.
     -> Text -- ^ Text representing a @GraphQL@ request document.
@@ -25,7 +25,7 @@ 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.
+-- 'Schema'.
 graphqlSubs :: (Monad m, VariableValue a)
     => Schema m -- ^ Resolvers.
     -> HashMap Name a -- ^ Variable substitution function.

src/Language/GraphQL/Error.hs

@@ -29,6 +29,7 @@ import Text.Megaparsec
     , unPos
     )
 
+-- | Executor context.
 data Resolution m = Resolution
     { errors :: [Aeson.Value]
     , types :: HashMap Name (Type m)

src/Language/GraphQL/Execute.hs

@@ -11,10 +11,10 @@ import Data.Sequence (Seq(..))
 import Data.Text (Text)
 import Language.GraphQL.AST.Document (Document, Name)
 import Language.GraphQL.Execute.Coerce
+import Language.GraphQL.Execute.Execution
 import qualified Language.GraphQL.Execute.Transform as Transform
 import Language.GraphQL.Error
 import Language.GraphQL.Type.Definition
-import qualified Language.GraphQL.Schema as Schema
 import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Type.Schema
 
@@ -68,4 +68,4 @@ executeOperation :: Monad m
     -> Seq (Transform.Selection m)
     -> m Aeson.Value
 executeOperation types' objectType fields =
-    runCollectErrs types' $ Schema.resolve Null objectType fields
+    runCollectErrs types' $ executeSelectionSet Null objectType fields

src/Language/GraphQL/Execute/Execution.hs

@@ -1,20 +1,38 @@
 {-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE OverloadedStrings #-}
+
 module Language.GraphQL.Execute.Execution
-    ( aliasOrName
+    ( executeSelectionSet
-    , collectFields
     ) where
 
+import qualified Data.Aeson as Aeson
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Except (runExceptT)
+import Control.Monad.Trans.Reader (runReaderT)
+import Control.Monad.Trans.State (gets)
 import Data.Map.Strict (Map)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Map.Strict as Map
 import Data.Maybe (fromMaybe)
-import Data.Sequence (Seq)
+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.Error
 import Language.GraphQL.Execute.Transform
+import Language.GraphQL.Trans
+import Language.GraphQL.Type.Definition
 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 result (Field _ _ args _) =
+    flip runReaderT (Context {arguments=args, values=result})
+    . runExceptT
+    . runActionT
+
 collectFields :: Monad m
     => Out.ObjectType m
     -> Seq (Selection m)
@@ -34,6 +52,21 @@ collectFields objectType = foldl forEach Map.empty
 aliasOrName :: forall m. Field m -> Name
 aliasOrName (Field alias name _ _) = fromMaybe name alias
 
+resolveAbstractType :: Monad m
+    => AbstractType m
+    -> HashMap Name Value
+    -> CollectErrsT m (Maybe (Out.ObjectType m))
+resolveAbstractType abstractType values'
+    | Just (String typeName) <- HashMap.lookup "__typename" values' = do
+        types' <- gets types
+        case HashMap.lookup typeName types' of
+            Just (ObjectType objectType) ->
+                if instanceOf objectType abstractType
+                    then pure $ Just objectType
+                    else pure Nothing
+            _ -> pure Nothing
+    | otherwise = pure Nothing
+
 doesFragmentTypeApply :: forall m
     . CompositeType m
     -> Out.ObjectType m
@@ -43,16 +76,88 @@ doesFragmentTypeApply (CompositeObjectType fragmentType) objectType =
         Out.ObjectType objectName _ _ _ = objectType
      in fragmentName == objectName
 doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType =
-    let Out.ObjectType _ _ interfaces _ = objectType
+    instanceOf objectType $ AbstractInterfaceType fragmentType
-     in foldr instanceOf False interfaces
-  where
-    instanceOf (Out.InterfaceType that _ interfaces _) acc =
-        let Out.InterfaceType this _ _ _ = fragmentType
-         in acc || foldr instanceOf (this == that) interfaces
 doesFragmentTypeApply (CompositeUnionType fragmentType) objectType =
-    let Out.UnionType _ _ members = fragmentType
+    instanceOf objectType $ AbstractUnionType fragmentType
-     in foldr instanceOf False members
+
+instanceOf :: forall m. Out.ObjectType m -> AbstractType m -> Bool
+instanceOf objectType (AbstractInterfaceType interfaceType) =
+    let Out.ObjectType _ _ interfaces _ = objectType
+     in foldr go False interfaces
   where
-    instanceOf (Out.ObjectType that _ _ _) acc =
+    go (Out.InterfaceType that _ interfaces _) acc =
+        let Out.InterfaceType this _ _ _ = interfaceType
+         in acc || foldr go (this == that) interfaces
+instanceOf objectType (AbstractUnionType unionType) =
+    let Out.UnionType _ _ members = unionType
+     in foldr go False members
+  where
+    go (Out.ObjectType that _ _ _) acc =
         let Out.ObjectType this _ _ _ = objectType
          in acc || this == that
+
+executeField :: Monad m
+    => Value
+    -> Out.Resolver m
+    -> Field m
+    -> CollectErrsT m Aeson.Value
+executeField prev (Out.Resolver fieldDefinition resolver) field = do
+    let Out.Field _ fieldType _ = fieldDefinition
+    answer <- lift $ resolveFieldValue prev field resolver
+    case answer of
+        Right result -> completeValue fieldType field result
+        Left errorMessage -> errmsg errorMessage
+
+completeValue :: Monad m
+    => Out.Type m
+    -> Field m
+    -> Value
+    -> CollectErrsT m Aeson.Value
+completeValue _ _ Null = pure Aeson.Null
+completeValue _ _ (Int integer) = pure $ Aeson.toJSON integer
+completeValue _ _ (Boolean boolean') = pure $ Aeson.Bool boolean'
+completeValue _ _ (Float float') = pure $ Aeson.toJSON float'
+completeValue _ _ (Enum enum) = pure $ Aeson.String enum
+completeValue _ _ (String string') = pure $ Aeson.String string'
+completeValue (Out.ObjectBaseType objectType) (Field _ _ _ seqSelection) result =
+    executeSelectionSet result objectType seqSelection
+completeValue (Out.ListBaseType listType) selectionField (List list) =
+    Aeson.toJSON <$> traverse (completeValue listType selectionField) list
+completeValue (Out.InterfaceBaseType interfaceType) (Field _ _ _ seqSelection) result
+    | 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
+        abstractType <- resolveAbstractType (AbstractUnionType unionType) objectMap
+        case abstractType of
+            Just objectType -> executeSelectionSet result objectType seqSelection
+            Nothing -> errmsg "Value completion failed."
+completeValue _ _ _ = errmsg "Value completion failed."
+
+errmsg :: Monad m => Text -> CollectErrsT m Aeson.Value
+errmsg errorMessage = addErrMsg errorMessage >> pure Aeson.Null
+
+-- | Takes an 'Out.ObjectType' and a list of 'Selection's and applies each field
+-- to each 'Selection'. Resolves into a value containing the resolved
+-- 'Selection', or a null value and error information.
+executeSelectionSet :: Monad m
+    => Value
+    -> Out.ObjectType m
+    -> Seq (Selection m)
+    -> CollectErrsT m Aeson.Value
+executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do
+    resolvedValues <- Map.traverseMaybeWithKey forEach
+        $ collectFields objectType selectionSet
+    pure $ Aeson.toJSON resolvedValues
+  where
+    forEach _responseKey (field :<| _) =
+        tryResolvers field >>= lift . pure . pure
+    forEach _ _ = pure Nothing
+    lookupResolver = flip HashMap.lookup resolvers
+    tryResolvers fld@(Field _ name _ _)
+        | Just typeField <- lookupResolver name =
+            executeField result typeField fld
+        | otherwise = errmsg $ Text.unwords ["field", name, "not resolved."]

src/Language/GraphQL/Schema.hs

@@ -1,105 +0,0 @@
-{-# LANGUAGE ExplicitForAll #-}
-{-# LANGUAGE OverloadedStrings #-}
-
--- | This module provides a representation of a @GraphQL@ Schema in addition to
--- functions for defining and manipulating schemas.
-module Language.GraphQL.Schema
-    ( Resolver(..)
-    , resolve
-    ) where
-
-import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Except (runExceptT)
-import Control.Monad.Trans.Reader (runReaderT)
-import qualified Data.Aeson as Aeson
-import qualified Data.HashMap.Strict as HashMap
-import qualified Data.Map.Strict as Map
-import Data.Sequence (Seq(..))
-import Data.Text (Text)
-import qualified Data.Text as Text
-import Language.GraphQL.AST.Document (Name)
-import Language.GraphQL.Error
-import Language.GraphQL.Execute.Execution
-import Language.GraphQL.Execute.Transform
-import Language.GraphQL.Trans
-import Language.GraphQL.Type.Definition
-import qualified Language.GraphQL.Type.Out as Out
-
--- | 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'.
---
--- 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 Resolver m = Resolver Name (ActionT m Value)
-
-resolveFieldValue :: Monad m => Value -> Field m -> ActionT m a -> m (Either Text a)
-resolveFieldValue result (Field _ _ args _) =
-    flip runReaderT (Context {arguments=args, values=result})
-    . runExceptT
-    . runActionT
-
-executeField :: Monad m
-    => Value
-    -> Out.Field m
-    -> Field m
-    -> CollectErrsT m Aeson.Value
-executeField prev (Out.Field _ fieldType _ resolver) field = do
-    answer <- lift $ resolveFieldValue prev field resolver
-    case answer of
-        Right result -> completeValue fieldType field result
-        Left errorMessage -> errmsg errorMessage
-
-completeValue :: Monad m
-    => Out.Type m
-    -> Field m
-    -> Value
-    -> CollectErrsT m Aeson.Value
-completeValue _ _ Null = pure Aeson.Null
-completeValue _ _ (Int integer) = pure $ Aeson.toJSON integer
-completeValue _ _ (Boolean boolean') = pure $ Aeson.Bool boolean'
-completeValue _ _ (Float float') = pure $ Aeson.toJSON float'
-completeValue _ _ (Enum enum) = pure $ Aeson.String enum
-completeValue _ _ (String string') = pure $ Aeson.String string'
-completeValue (Out.ObjectBaseType objectType) (Field _ _ _ seqSelection) result =
-    resolve result objectType seqSelection
-completeValue (Out.ListBaseType listType) selectionField (List list) =
-    Aeson.toJSON <$> traverse (completeValue listType selectionField) list
-completeValue _ _ _ = errmsg "Value completion failed."
-
-errmsg :: Monad m => Text -> CollectErrsT m Aeson.Value
-errmsg errorMessage = addErrMsg errorMessage >> pure Aeson.Null
-
--- | Takes a list of 'Resolver's and a list of 'Field's and applies each
--- 'Resolver' to each 'Field'. Resolves into a value containing the
--- resolved 'Field', or a null value and error information.
-resolve :: Monad m -- executeSelectionSet
-    => Value
-    -> Out.ObjectType m
-    -> Seq (Selection m)
-    -> CollectErrsT m Aeson.Value
-resolve result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do
-    resolvedValues <- Map.traverseMaybeWithKey forEach
-        $ collectFields objectType selectionSet
-    pure $ Aeson.toJSON resolvedValues
-  where
-    forEach _responseKey (field :<| _) =
-        tryResolvers field >>= lift . pure . pure
-    forEach _ _ = pure Nothing
-    lookupResolver = flip HashMap.lookup resolvers
-    tryResolvers fld@(Field _ name _ _)
-        | Just typeField <- lookupResolver name =
-            executeField result typeField fld
-        | otherwise = errmsg $ Text.unwords ["field", name, "not resolved."]
-    {-tryResolvers (Out.SelectionFragment (Out.Fragment typeCondition selections'))
-        | Just (Out.Field _ _ _ resolver) <- lookupResolver "__typename" = do
-            let fakeField = Out.Field Nothing "__typename" mempty mempty
-            that <- lift $ resolveFieldValue result fakeField resolver
-            case that of
-                Right (String typeCondition')
-                    | (Out.CompositeObjectType (Out.ObjectType n _ _ _)) <- typeCondition
-                    , typeCondition' == n ->
-                        fmap fold . traverse tryResolvers $ selections'
-                _ -> pure mempty
-        | otherwise = fmap fold . traverse tryResolvers $ selections'-}

src/Language/GraphQL/Type/Out.hs

@@ -10,6 +10,7 @@ module Language.GraphQL.Type.Out
     ( Field(..)
     , InterfaceType(..)
     , ObjectType(..)
+    , Resolver(..)
     , Type(..)
     , UnionType(..)
     , isNonNullType
@@ -27,13 +28,22 @@ import Language.GraphQL.AST.Core
 import Language.GraphQL.Trans
 import Language.GraphQL.Type.Definition
 import qualified Language.GraphQL.Type.In as In
+
+-- | 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'.
 --
+-- 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 Resolver m = Resolver (Field m) (ActionT m Value)
+
 -- | 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 (Maybe Text) [InterfaceType m] (HashMap Name (Field m))
+    Name (Maybe Text) [InterfaceType m] (HashMap Name (Resolver m))
 
 -- | Interface Type Definition.
 --
@@ -54,7 +64,6 @@ data Field m = Field
     (Maybe Text) -- ^ Description.
     (Type m) -- ^ Field type.
     (HashMap Name In.Argument) -- ^ Arguments.
-    (ActionT m Value) -- ^ Resolver.
 
 -- | These types may be used as output types as the result of fields.
 --

src/Language/GraphQL/Type/Schema.hs

@@ -1,8 +1,10 @@
 {-# LANGUAGE ExplicitForAll #-}
 
--- | Schema Definition.
+-- | This module provides a representation of a @GraphQL@ Schema in addition to
+-- functions for defining and manipulating schemas.
 module Language.GraphQL.Type.Schema
-    ( CompositeType(..)
+    ( AbstractType(..)
+    , CompositeType(..)
     , Schema(..)
     , Type(..)
     , collectReferencedTypes
@@ -30,6 +32,11 @@ data CompositeType m
     | CompositeObjectType (Out.ObjectType m)
     | CompositeInterfaceType (Out.InterfaceType m)
 
+-- | These types may describe the parent context of a selection set.
+data AbstractType m
+    = AbstractUnionType (Out.UnionType m)
+    | AbstractInterfaceType (Out.InterfaceType m)
+
 -- | 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.
@@ -51,7 +58,7 @@ collectReferencedTypes schema =
     collect traverser typeName element foundTypes
         | HashMap.member typeName foundTypes = foundTypes
         | otherwise = traverser $ HashMap.insert typeName element foundTypes
-    visitFields (Out.Field _ outputType arguments _) foundTypes
+    visitFields (Out.Field _ outputType arguments) foundTypes
         = traverseOutputType outputType
         $ foldr visitArguments foundTypes arguments
     visitArguments (In.Argument _ inputType _) = traverseInputType inputType
@@ -86,15 +93,17 @@ collectReferencedTypes schema =
         let (Definition.EnumType typeName _ _) = enumType
          in collect Prelude.id typeName (EnumType enumType)
     traverseObjectType objectType foundTypes =
-        let (Out.ObjectType typeName _ interfaces fields) = objectType
+        let (Out.ObjectType typeName _ interfaces resolvers) = objectType
             element = ObjectType objectType
-            traverser = polymorphicTypeTraverser interfaces fields
+            fields = extractObjectField <$> resolvers
+            traverser = polymorphicTraverser interfaces fields
          in collect traverser typeName element foundTypes
     traverseInterfaceType interfaceType foundTypes =
         let (Out.InterfaceType typeName _ interfaces fields) = interfaceType
             element = InterfaceType interfaceType
-            traverser = polymorphicTypeTraverser interfaces fields
+            traverser = polymorphicTraverser interfaces fields
          in collect traverser typeName element foundTypes
-    polymorphicTypeTraverser interfaces fields
+    polymorphicTraverser interfaces fields
         = flip (foldr visitFields) fields
         . flip (foldr traverseInterfaceType) interfaces
+    extractObjectField (Out.Resolver field _) = field

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-15.14
+resolver: lts-15.15
 
 packages:
 - .

tests/Test/DirectiveSpec.hs

@@ -20,7 +20,7 @@ experimentalResolver = Schema { query = queryType, mutation = Nothing }
     resolver = pure $ Int 5
     queryType = Out.ObjectType "Query" Nothing []
         $ HashMap.singleton "experimentalField"
-        $ Out.Field Nothing (Out.NamedScalarType int) mempty resolver
+        $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty) resolver
 
 emptyObject :: Aeson.Value
 emptyObject = object

tests/Test/FragmentSpec.hs

@@ -54,32 +54,38 @@ hasErrors _ = True
 shirtType :: Out.ObjectType IO
 shirtType = Out.ObjectType "Shirt" Nothing []
     $ HashMap.fromList
-        [ ("size", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ snd size)
+        [ ("size", Out.Resolver sizeFieldType $ pure $ snd size)
-        , ("circumference", Out.Field Nothing (Out.NamedScalarType int) mempty $ pure $ snd circumference)
+        , ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference)
-        , ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ String "Shirt")
         ]
 
 hatType :: Out.ObjectType IO
 hatType = Out.ObjectType "Hat" Nothing []
     $ HashMap.fromList
-        [ ("size", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ snd size)
+        [ ("size", Out.Resolver sizeFieldType $ pure $ snd size)
-        , ("circumference", Out.Field Nothing (Out.NamedScalarType int) mempty $ pure $ snd circumference)
+        , ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference)
-        , ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ String "Hat")
         ]
 
+circumferenceFieldType :: Out.Field IO
+circumferenceFieldType = Out.Field Nothing (Out.NamedScalarType int) mempty
+
+sizeFieldType :: Out.Field IO
+sizeFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+
 toSchema :: Text -> (Text, Value) -> Schema IO
 toSchema t (_, resolve) = Schema
     { query = queryType, mutation = Nothing }
   where
     unionMember = if t == "Hat" then hatType else shirtType
+    typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty
+    garmentField = Out.Field Nothing (Out.NamedObjectType unionMember) mempty
     queryType =
         case t of
             "circumference" -> hatType
             "size" -> shirtType
             _ -> Out.ObjectType "Query" Nothing []
                 $ HashMap.fromList
-                    [ ("garment", Out.Field Nothing (Out.NamedObjectType unionMember) mempty $ pure resolve)
+                    [ ("garment", Out.Resolver garmentField $ pure resolve)
-                    , ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ String "Shirt")
+                    , ("__typename", Out.Resolver typeNameField $ pure $ String "Shirt")
                     ]
 
 spec :: Spec

tests/Test/RootOperationSpec.hs

@@ -16,7 +16,7 @@ import Language.GraphQL.Type.Schema
 hatType :: Out.ObjectType IO
 hatType = Out.ObjectType "Hat" Nothing []
     $ HashMap.singleton "circumference"
-    $ Out.Field Nothing (Out.NamedScalarType int) mempty
+    $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
     $ pure $ Int 60
 
 schema :: Schema IO
@@ -28,10 +28,10 @@ schema = Schema
         [ ("circumference", Int 60)
         ]
     incrementField = HashMap.singleton "incrementCircumference"
-        $ Out.Field Nothing (Out.NamedScalarType int) mempty
+        $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
         $ pure $ Int 61
     hatField = HashMap.singleton "garment"
-        $ Out.Field Nothing (Out.NamedObjectType hatType) mempty garment
+        $ Out.Resolver (Out.Field Nothing (Out.NamedObjectType hatType) mempty) garment
 
 spec :: Spec
 spec =

tests/Test/StarWars/Schema.hs

@@ -24,32 +24,51 @@ schema :: Schema Identity
 schema = Schema { query = queryType, mutation = Nothing }
   where
     queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
-        [ ("hero", Out.Field Nothing (Out.NamedObjectType heroObject) mempty hero)
+        [ ("hero", Out.Resolver (Out.Field Nothing (Out.NamedObjectType heroObject) mempty) hero)
-        , ("human", Out.Field Nothing (Out.NamedObjectType heroObject) mempty human)
+        , ("human", Out.Resolver (Out.Field Nothing (Out.NamedObjectType heroObject) mempty) human)
-        , ("droid", Out.Field Nothing (Out.NamedObjectType droidObject) mempty droid)
+        , ("droid", Out.Resolver (Out.Field Nothing (Out.NamedObjectType droidObject) mempty) droid)
         ]
 
 heroObject :: Out.ObjectType Identity
 heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
-    [ ("id", Out.Field Nothing (Out.NamedScalarType id) mempty (idField "id"))
+    [ ("id", Out.Resolver idFieldType (idField "id"))
-    , ("name", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "name"))
+    , ("name", Out.Resolver nameFieldType (idField "name"))
-    , ("friends", Out.Field Nothing (Out.ListType $ Out.NamedObjectType heroObject) mempty (idField "friends"))
+    , ("friends", Out.Resolver friendsFieldType (idField "friends"))
-    , ("appearsIn", Out.Field Nothing (Out.ListType $ Out.NamedScalarType int) mempty (idField "appearsIn"))
+    , ("appearsIn", Out.Resolver appearsInFieldType (idField "appearsIn"))
-    , ("homePlanet", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "homePlanet"))
+    , ("homePlanet", Out.Resolver homePlanetFieldType (idField "homePlanet"))
-    , ("secretBackstory", Out.Field Nothing (Out.NamedScalarType string) mempty (String <$> secretBackstory))
+    , ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))
-    , ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "__typename"))
+    , ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename"))
     ]
+  where
+    homePlanetFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
 
 droidObject :: Out.ObjectType Identity
 droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
-    [ ("id", Out.Field Nothing (Out.NamedScalarType id) mempty (idField "id"))
+    [ ("id", Out.Resolver idFieldType (idField "id"))
-    , ("name", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "name"))
+    , ("name", Out.Resolver nameFieldType (idField "name"))
-    , ("friends", Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty (idField "friends"))
+    , ("friends", Out.Resolver friendsFieldType (idField "friends"))
-    , ("appearsIn", Out.Field Nothing (Out.ListType $ Out.NamedScalarType int) mempty (idField "appearsIn"))
+    , ("appearsIn", Out.Resolver appearsInFieldType (idField "appearsIn"))
-    , ("primaryFunction", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "primaryFunction"))
+    , ("primaryFunction", Out.Resolver primaryFunctionFieldType (idField "primaryFunction"))
-    , ("secretBackstory", Out.Field Nothing (Out.NamedScalarType string) mempty (String <$> secretBackstory))
+    , ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))
-    , ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "__typename"))
+    , ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename"))
     ]
+  where
+    primaryFunctionFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+
+idFieldType :: Out.Field Identity
+idFieldType = Out.Field Nothing (Out.NamedScalarType id) mempty
+
+nameFieldType :: Out.Field Identity
+nameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+
+friendsFieldType :: Out.Field Identity
+friendsFieldType = Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty
+
+appearsInFieldType :: Out.Field Identity
+appearsInFieldType = Out.Field Nothing (Out.ListType $ Out.NamedScalarType int) mempty
+
+secretBackstoryFieldType :: Out.Field Identity
+secretBackstoryFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
 
 idField :: Text -> ActionT Identity Value
 idField f = do