Resolve abstract types

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

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
-    , collectFields
+    ( executeSelectionSet
     ) 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
-     in foldr instanceOf False interfaces
-  where
-    instanceOf (Out.InterfaceType that _ interfaces _) acc =
-        let Out.InterfaceType this _ _ _ = fragmentType
-         in acc || foldr instanceOf (this == that) interfaces
+    instanceOf objectType $ AbstractInterfaceType fragmentType
 doesFragmentTypeApply (CompositeUnionType fragmentType) objectType =
-    let Out.UnionType _ _ members = fragmentType
-     in foldr instanceOf False members
+    instanceOf objectType $ AbstractUnionType fragmentType
+
+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