Add Union and Interface type definitions

2020-05-26 11:13:55 +02:00 · 2020-05-26 11:13:55 +02:00 · c06d0b8e95
commit c06d0b8e95
parent 61dbe6c728
11 changed files with 229 additions and 124 deletions
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@ -23,10 +23,8 @@ and this project adheres to
  returns a resolver (just the function). There is no need in special functions
  to construct field resolvers anymore, they can be constructed with just
  `Resolver "fieldName" $ pure $ object [...]`.
- `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`.
+- `AST.Core.Document` was modified to contain only slightly modified AST and
+  moved into `Execute.Transform.Document`.
 - `AST.Core.Value` was moved into `Type.In`. Input 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
@ -38,18 +36,18 @@ and this project adheres to
 - `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.
- `Type.In` and `Type.Out` contain definitions for input and the most output
-  types.
+- `Type.In` and `Type.Out` contain definitions for input and output types.
 - `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
+- `Execute.Transform.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, moved to
-  `Execute.Transform` and made private.
+  interested only in one of them. `Execute.Transform.operation` has the prior
+  responsibility of `Execute.Transform.document`, but transforms only the
+  chosen operation and not the whole document.
 - `Schema.scalar`, `Schema.wrappedScalar`. They accepted everything can be
  converted to JSON and JSON is not suitable as an internal representation for
  GraphQL. E.g. GraphQL distinguishes between Floats and Integersa and we need
--- a/docs/tutorial/tutorial.lhs
+++ b/docs/tutorial/tutorial.lhs
@ -40,7 +40,7 @@ First we build a GraphQL schema.
 > schema1 = Schema queryType Nothing
 >
 > queryType :: ObjectType IO
-> queryType = ObjectType "Query" Nothing
+> queryType = ObjectType "Query" Nothing []
 >   $ HashMap.singleton "hello"
 >   $ Field Nothing (Out.NamedScalarType string) mempty hello
 >
@ -75,7 +75,7 @@ For this example, we're going to be using time.
 > schema2 = Schema queryType2 Nothing
 >
 > queryType2 :: ObjectType IO
-> queryType2 = ObjectType "Query" Nothing
+> queryType2 = ObjectType "Query" Nothing []
 >   $ HashMap.singleton "time"
 >   $ Field Nothing (Out.NamedScalarType string) mempty time
 >
@ -139,7 +139,7 @@ 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" Nothing $ HashMap.fromList
+> queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList
 >   [ ("hello", Field Nothing (Out.NamedScalarType string) mempty hello)
 >   , ("time", Field Nothing (Out.NamedScalarType string) mempty time)
 >   ]
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@ -9,6 +9,7 @@ module Language.GraphQL.Execute

 import qualified Data.Aeson as Aeson
 import qualified Data.HashMap.Strict as HashMap
+import Data.Sequence (Seq(..))
 import Data.Text (Text)
 import Language.GraphQL.AST.Document
 import qualified Language.GraphQL.AST.Core as AST.Core
@ -29,7 +30,7 @@ execute :: (Monad m, VariableValue a)
    -> HashMap.HashMap Name a -- ^ Variable substitution function.
    -> Document -- @GraphQL@ document.
    -> m Aeson.Value
-execute schema = document schema Nothing
+execute schema = executeRequest schema Nothing

 -- | 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
@ -43,36 +44,34 @@ executeWithName :: (Monad m, VariableValue a)
    -> HashMap.HashMap Name a -- ^ Variable substitution function.
    -> Document -- ^ @GraphQL@ Document.
    -> m Aeson.Value
-executeWithName schema operationName = document schema (Just operationName)
+executeWithName schema operationName =
+    executeRequest schema (Just operationName)

-document :: (Monad m, VariableValue a)
+executeRequest :: (Monad m, VariableValue a)
    => Schema m
    -> Maybe Text
    -> HashMap.HashMap Name a
    -> Document
    -> m Aeson.Value
-document schema operationName subs document' =
-    case Transform.document schema operationName subs document' of
+executeRequest schema operationName subs document =
+    case Transform.document schema operationName subs document of
        Left queryError -> pure $ singleError $ Transform.queryError queryError
-        Right (Transform.Document operation') -> operation schema operation'
+        Right (Transform.Document rootObjectType operation)
+          | (AST.Core.Query _ fields) <- operation ->
+              executeOperation rootObjectType fields
+          | (AST.Core.Mutation _ fields) <- operation ->
+              executeOperation rootObjectType fields

-operation :: Monad m
-    => Schema m
-    -> AST.Core.Operation
+-- This is actually executeMutation, but we don't distinguish between queries
+-- and mutations yet.
+executeOperation :: Monad m
+    => Out.ObjectType m
+    -> Seq AST.Core.Selection
    -> m Aeson.Value
-operation = schemaOperation
+executeOperation (Out.ObjectType _ _ _ objectFields) fields
+    = runCollectErrs
+    $ flip Schema.resolve fields
+    $ fmap getResolver
+    $ objectFields
  where
-    resolve queryFields = runCollectErrs
-        . flip Schema.resolve queryFields
-        . fmap getResolver
-        . fields
-    fields (Out.ObjectType _ _ objectFields) = objectFields
-    lookupError = pure
-        $ singleError "Root operation type couldn't be found in the schema."
-    schemaOperation Schema {query} (AST.Core.Query _ fields') =
-        resolve fields' query
-    schemaOperation Schema {mutation = Just mutation} (AST.Core.Mutation _ fields') =
-        resolve fields' mutation
-    schemaOperation Schema {mutation = Nothing} (AST.Core.Mutation _ _) =
-        lookupError
    getResolver (Out.Field _ _ _ resolver) = resolver
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@ -1,11 +1,20 @@
 {-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# 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.
+-- | After the document is parsed, before getting executed, the AST is
+-- transformed into a similar, simpler AST. Performed transformations include:
+--
+--   * Replacing variables with their values.
+--   * Inlining fragments. Some fragments can be completely eliminated and
+--   replaced by the selection set they represent. Invalid (recursive and
+--   non-existing) fragments are skipped. The most fragments are inlined, so the
+--   executor doesn't have to perform additional lookups later.
+--
+-- This module is also responsible for smaller rewrites that touch only parts of
+-- the original AST.
 module Language.GraphQL.Execute.Transform
    ( Document(..)
    , QueryError(..)
@ -32,19 +41,21 @@ import Language.GraphQL.Execute.Coerce
 import qualified Language.GraphQL.Schema as Schema
 import qualified Language.GraphQL.Type.Directive as Directive
 import qualified Language.GraphQL.Type.In as In
+import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Type.Schema

 -- | Associates a fragment name with a list of 'Core.Field's.
-data Replacement = Replacement
+data Replacement m = Replacement
    { fragments :: HashMap Core.Name Core.Fragment
-    , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
+    , fragmentDefinitions :: FragmentDefinitions
    , variableValues :: Schema.Subs
+    , types :: HashMap Full.Name (Type m)
    }

-type TransformT a = State Replacement a
+type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition

-- | GraphQL document is a non-empty list of operations.
-newtype Document = Document Core.Operation
+-- | Contains the operation to be executed along with its root type.
+data Document m = Document (Out.ObjectType m) Core.Operation

 data OperationDefinition = OperationDefinition
    Full.OperationType
@ -60,6 +71,7 @@ data QueryError
    | CoercionError
    | TransformationError
    | EmptyDocument
+    | UnsupportedRootOperation

 queryError :: QueryError -> Text
 queryError (OperationNotFound operationName) = Text.unwords
@ -69,6 +81,8 @@ queryError CoercionError = "Coercion error."
 queryError TransformationError = "Schema transformation error."
 queryError EmptyDocument =
    "The document doesn't contain any executable operations."
+queryError UnsupportedRootOperation =
+    "Root operation type couldn't be found in the schema."

 getOperation
    :: Maybe Full.Name
@ -112,25 +126,24 @@ lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types
    = In.NonNullListType
    <$> lookupInputType nonNull types

-coerceVariableValues :: (Monad m, VariableValue a)
-    => Schema m
+coerceVariableValues :: VariableValue a
+    => forall m
+    . HashMap Full.Name (Type m)
    -> OperationDefinition
    -> HashMap.HashMap Full.Name a
    -> Either QueryError Schema.Subs
-coerceVariableValues schema operationDefinition variableValues' =
-    let referencedTypes = collectReferencedTypes schema
-        OperationDefinition _ _ variableDefinitions _ _ = operationDefinition
-        coerceValue' = coerceValue referencedTypes
+coerceVariableValues types operationDefinition variableValues' =
+    let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition
     in maybe (Left CoercionError) Right
-        $ foldr coerceValue' (Just HashMap.empty) variableDefinitions
+        $ foldr coerceValue (Just HashMap.empty) variableDefinitions
  where
-    coerceValue referencedTypes variableDefinition coercedValues = do
+    coerceValue variableDefinition coercedValues = do
        let Full.VariableDefinition variableName variableTypeName defaultValue =
                variableDefinition
        let defaultValue' = constValue <$> defaultValue
        let value' = HashMap.lookup variableName variableValues'

-        variableType <- lookupInputType variableTypeName referencedTypes
+        variableType <- lookupInputType variableTypeName types
        HashMap.insert variableName
            <$> choose value' defaultValue' variableType
            <*> coercedValues
@ -158,23 +171,46 @@ constValue (Full.ConstObject o) =

 -- | Rewrites the original syntax tree into an intermediate representation used
 -- for query execution.
-document :: (Monad m, VariableValue a)
-    => Schema m
+document :: VariableValue a
+    => forall m
+    . Schema m
    -> Maybe Full.Name
    -> HashMap Full.Name a
    -> Full.Document
-    -> Either QueryError Document
+    -> Either QueryError (Document m)
 document schema operationName subs ast = do
-    let (operations, fragmentTable) = foldr defragment ([], HashMap.empty) ast
-    nonEmptyOperations <- maybe (Left EmptyDocument) Right
-        $ NonEmpty.nonEmpty operations
-    chosenOperation <- getOperation operationName nonEmptyOperations
-    coercedValues <- coerceVariableValues schema chosenOperation subs
+    let referencedTypes = collectReferencedTypes schema

-    pure $ Document
-        $ operation fragmentTable coercedValues chosenOperation
+    (operations, fragmentTable) <- defragment ast
+    chosenOperation <- getOperation operationName operations
+    coercedValues <- coerceVariableValues referencedTypes chosenOperation subs
+
+    let replacement = Replacement
+            { fragments = HashMap.empty
+            , fragmentDefinitions = fragmentTable
+            , variableValues = coercedValues
+            , types = referencedTypes
+            }
+    case chosenOperation of
+        OperationDefinition Full.Query _ _ _ _ ->
+            pure $ Document (query schema)
+                $ operation (query schema) chosenOperation replacement
+        OperationDefinition Full.Mutation _ _ _ _
+            | Just mutationType <- mutation schema ->
+                pure $ Document mutationType
+                    $ operation mutationType chosenOperation replacement
+        _ -> Left UnsupportedRootOperation
+
+defragment
+    :: Full.Document
+    -> Either QueryError (NonEmpty OperationDefinition, FragmentDefinitions)
+defragment ast =
+    let (operations, fragmentTable) = foldr defragment' ([], HashMap.empty) ast
+        nonEmptyOperations = NonEmpty.nonEmpty operations
+        emptyDocument = Left EmptyDocument
+     in (, fragmentTable) <$> maybe emptyDocument Right nonEmptyOperations
  where
-    defragment definition (operations, fragments')
+    defragment' definition (operations, fragments')
        | (Full.ExecutableDefinition executable) <- definition
        , (Full.DefinitionOperation operation') <- executable =
            (transform operation' : operations, fragments')
@ -182,7 +218,7 @@ document schema operationName subs ast = do
        , (Full.DefinitionFragment fragment) <- executable
        , (Full.FragmentDefinition name _ _ _) <- fragment =
            (operations, HashMap.insert name fragment fragments')
-    defragment _ acc = acc
+    defragment' _ acc = acc
    transform = \case
        Full.OperationDefinition type' name variables directives' selections ->
            OperationDefinition type' name variables directives' selections
@ -191,35 +227,34 @@ document schema operationName subs ast = do

 -- * Operation

-operation
-    :: HashMap Full.Name Full.FragmentDefinition
-    -> Schema.Subs
+operation :: forall m
+    . Out.ObjectType m
    -> OperationDefinition
+    -> Replacement m
    -> Core.Operation
-operation fragmentTable subs operationDefinition
+operation rootType operationDefinition replacement
    = runIdentity
-    $ evalStateT (collectFragments >> transform operationDefinition)
-    $ Replacement HashMap.empty fragmentTable subs
+    $ evalStateT (collectFragments rootType >> transform operationDefinition) replacement
  where
-    transform :: OperationDefinition -> TransformT Core.Operation
    transform (OperationDefinition Full.Query name _ _ sels) =
-        Core.Query name <$> appendSelection sels
+        Core.Query name <$> appendSelection sels rootType
    transform (OperationDefinition Full.Mutation name _ _ sels) =
-        Core.Mutation name <$> appendSelection sels
+        Core.Mutation name <$> appendSelection sels rootType

 -- * Selection

-selection ::
-    Full.Selection ->
-    TransformT (Either (Seq Core.Selection) Core.Selection)
-selection (Full.Field alias name arguments' directives' selections) =
+selection :: forall m
+    . Full.Selection
+    -> Out.ObjectType m
+    -> State (Replacement m) (Either (Seq Core.Selection) Core.Selection)
+selection (Full.Field alias name arguments' directives' selections) objectType =
    maybe (Left mempty) (Right . Core.SelectionField) <$> do
        fieldArguments <- arguments arguments'
-        fieldSelections <- appendSelection selections
+        fieldSelections <- appendSelection selections objectType
        fieldDirectives <- Directive.selection <$> directives directives'
        let field' = Core.Field alias name fieldArguments fieldSelections
        pure $ field' <$ fieldDirectives
-selection (Full.FragmentSpread name directives') =
+selection (Full.FragmentSpread name directives') objectType =
    maybe (Left mempty) (Right . Core.SelectionFragment) <$> do
        spreadDirectives <- Directive.selection <$> directives directives'
        fragments' <- gets fragments
@ -229,32 +264,35 @@ selection (Full.FragmentSpread name directives') =
            Just definition -> lift $ pure $ definition <$ spreadDirectives
            Nothing -> case HashMap.lookup name fragmentDefinitions' of
                         Just definition -> do
-                             fragment <- fragmentDefinition definition
+                             fragment <- fragmentDefinition definition objectType
                             lift $ pure $ fragment <$ spreadDirectives
                         Nothing -> lift $ pure  Nothing
-selection (Full.InlineFragment type' directives' selections) = do
+selection (Full.InlineFragment type' directives' selections) objectType = do
    fragmentDirectives <- Directive.selection <$> directives directives'
    case fragmentDirectives of
        Nothing -> pure $ Left mempty
        _ -> do
-            fragmentSelectionSet <- appendSelection selections
+            fragmentSelectionSet <- appendSelection selections objectType
            pure $ maybe Left selectionFragment type' fragmentSelectionSet
  where
    selectionFragment typeName = Right
        . Core.SelectionFragment
        . Core.Fragment typeName

-appendSelection ::
-    Traversable t =>
-    t Full.Selection ->
-    TransformT (Seq Core.Selection)
-appendSelection = foldM go mempty
+appendSelection :: Traversable t
+    => forall m
+    . t Full.Selection
+    -> Out.ObjectType m
+    -> State (Replacement m) (Seq Core.Selection)
+appendSelection selectionSet objectType = foldM go mempty selectionSet
  where
-    go acc sel = append acc <$> selection sel
+    go acc sel = append acc <$> selection sel objectType
    append acc (Left list) = list >< acc
    append acc (Right one) = one <| acc

-directives :: [Full.Directive] -> TransformT [Core.Directive]
+directives :: forall m
+    . [Full.Directive]
+    -> State (Replacement m) [Core.Directive]
 directives = traverse directive
  where
    directive (Full.Directive directiveName directiveArguments) =
@ -263,38 +301,40 @@ directives = traverse directive
 -- * Fragment replacement

 -- | Extract fragment definitions into a single 'HashMap'.
-collectFragments :: TransformT ()
-collectFragments = do
+collectFragments :: forall m. Out.ObjectType m -> State (Replacement m) ()
+collectFragments objectType = do
    fragDefs <- gets fragmentDefinitions
    let nextValue = head $ HashMap.elems fragDefs
    unless (HashMap.null fragDefs) $ do
-        _ <- fragmentDefinition nextValue
-        collectFragments
+        _ <- fragmentDefinition nextValue objectType
+        collectFragments objectType

-fragmentDefinition ::
-    Full.FragmentDefinition ->
-    TransformT Core.Fragment
-fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
+fragmentDefinition :: forall m
+    . Full.FragmentDefinition
+    -> Out.ObjectType m
+    -> State (Replacement m) Core.Fragment
+fragmentDefinition (Full.FragmentDefinition name type' _ selections) objectType = do
    modify deleteFragmentDefinition
-    fragmentSelection <- appendSelection selections
+    fragmentSelection <- appendSelection selections objectType
    let newValue = Core.Fragment type' fragmentSelection
    modify $ insertFragment newValue
    lift $ pure newValue
  where
-    deleteFragmentDefinition (Replacement fragments' fragmentDefinitions' subs) =
-        Replacement fragments' (HashMap.delete name fragmentDefinitions') subs
-    insertFragment newValue (Replacement fragments' fragmentDefinitions' subs) =
-        let newFragments = HashMap.insert name newValue fragments'
-         in Replacement newFragments fragmentDefinitions' subs
+    deleteFragmentDefinition replacement@Replacement{..} =
+        let newDefinitions = HashMap.delete name fragmentDefinitions
+         in replacement{ fragmentDefinitions = newDefinitions }
+    insertFragment newValue replacement@Replacement{..} =
+        let newFragments = HashMap.insert name newValue fragments
+         in replacement{ fragments = newFragments }

-arguments :: [Full.Argument] -> TransformT Core.Arguments
+arguments :: forall m. [Full.Argument] -> State (Replacement m) Core.Arguments
 arguments = fmap Core.Arguments . foldM go HashMap.empty
  where
    go arguments' (Full.Argument name value') = do
        substitutedValue <- value value'
        return $ HashMap.insert name substitutedValue arguments'

-value :: Full.Value -> TransformT In.Value
+value :: forall m. Full.Value -> State (Replacement m) In.Value
 value (Full.Variable name) =
    gets $ fromMaybe In.Null . HashMap.lookup name . variableValues
 value (Full.Int i) = pure $ In.Int i
@ -303,10 +343,11 @@ value (Full.String x) = pure $ In.String x
 value (Full.Boolean b) = pure $ In.Boolean b
 value Full.Null = pure   In.Null
 value (Full.Enum e) = pure $ In.Enum e
-value (Full.List l) =
-    In.List <$> traverse value l
+value (Full.List l) = In.List <$> traverse value l
 value (Full.Object o) =
    In.Object . HashMap.fromList <$> traverse objectField o

-objectField :: Full.ObjectField Full.Value -> TransformT (Core.Name, In.Value)
+objectField :: forall m
+    . Full.ObjectField Full.Value
+    -> State (Replacement m) (Core.Name, In.Value)
 objectField (Full.ObjectField name value') = (name,) <$> value value'
--- a/src/Language/GraphQL/Type.hs
+++ b/src/Language/GraphQL/Type.hs
@ -3,7 +3,9 @@ module Language.GraphQL.Type
    ( In.InputField(..)
    , In.InputObjectType(..)
    , Out.Field(..)
+    , Out.InterfaceType(..)
    , Out.ObjectType(..)
+    , Out.UnionType(..)
    , module Language.GraphQL.Type.Definition
    , module Language.GraphQL.Type.Schema
    ) where
--- a/src/Language/GraphQL/Type/Out.hs
+++ b/src/Language/GraphQL/Type/Out.hs
@ -9,14 +9,18 @@
 -- with 'Language.GraphQL.Type.In'.
 module Language.GraphQL.Type.Out
    ( Field(..)
+    , InterfaceType(..)
    , ObjectType(..)
    , Type(..)
+    , UnionType(..)
    , Value(..)
    , isNonNullType
    , pattern EnumBaseType
+    , pattern InterfaceBaseType
    , pattern ListBaseType
    , pattern ObjectBaseType
    , pattern ScalarBaseType
+    , pattern UnionBaseType
    ) where

 import Data.HashMap.Strict (HashMap)
@ -34,7 +38,22 @@ import qualified Language.GraphQL.Type.In as In
 --
 --   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) (HashMap Name (Field m))
+data ObjectType m = ObjectType
+    Name (Maybe Text) [InterfaceType m] (HashMap Name (Field m))
+
+-- | Interface Type Definition.
+--
+-- When a field can return one of a heterogeneous set of types, a Interface type
+-- is used to describe what types are possible, and what fields are in common
+-- across all types.
+data InterfaceType m = InterfaceType
+    Name (Maybe Text) [InterfaceType m] (HashMap Name (Field m))
+
+-- | Union Type Definition.
+--
+-- When a field can return one of a heterogeneous set of types, a Union type is
+-- used to describe what types are possible.
+data UnionType m = UnionType Name (Maybe Text) [ObjectType m]

 -- | Output object field definition.
 data Field m = Field
@ -48,10 +67,14 @@ data Type m
    = NamedScalarType ScalarType
    | NamedEnumType EnumType
    | NamedObjectType (ObjectType m)
+    | NamedInterfaceType (InterfaceType m)
+    | NamedUnionType (UnionType m)
    | ListType (Type m)
    | NonNullScalarType ScalarType
    | NonNullEnumType EnumType
    | NonNullObjectType (ObjectType m)
+    | NonNullInterfaceType (InterfaceType m)
+    | NonNullUnionType (UnionType m)
    | NonNullListType (Type m)

 -- | GraphQL distinguishes between "wrapping" and "named" types. Each wrapping
@ -108,11 +131,26 @@ pattern EnumBaseType enumType <- (isEnumType -> Just enumType)
 pattern ObjectBaseType :: forall m. ObjectType m -> Type m
 pattern ObjectBaseType objectType <- (isObjectType -> Just objectType)

+-- | Matches either 'NamedInterfaceType' or 'NonNullInterfaceType'.
+pattern InterfaceBaseType :: forall m. InterfaceType m -> Type m
+pattern InterfaceBaseType interfaceType <-
+    (isInterfaceType -> Just interfaceType)
+
+-- | Matches either 'NamedUnionType' or 'NonNullUnionType'.
+pattern UnionBaseType :: forall m. UnionType m -> Type m
+pattern UnionBaseType unionType <- (isUnionType -> Just unionType)
+
 -- | Matches either 'ListType' or 'NonNullListType'.
 pattern ListBaseType :: forall m. Type m -> Type m
 pattern ListBaseType listType <- (isListType -> Just listType)

-{-# COMPLETE ScalarBaseType, EnumBaseType, ObjectBaseType, ListBaseType #-}
+{-# COMPLETE ScalarBaseType
+    , EnumBaseType
+    , ObjectBaseType
+    , ListBaseType
+    , InterfaceBaseType
+    , UnionBaseType
+    #-}

 isScalarType :: forall m. Type m -> Maybe ScalarType
 isScalarType (NamedScalarType outputType) = Just outputType
@ -129,6 +167,16 @@ isEnumType (NamedEnumType outputType) = Just outputType
 isEnumType (NonNullEnumType outputType) = Just outputType
 isEnumType _ = Nothing

+isInterfaceType :: forall m. Type m -> Maybe (InterfaceType m)
+isInterfaceType (NamedInterfaceType interfaceType) = Just interfaceType
+isInterfaceType (NonNullInterfaceType interfaceType) = Just interfaceType
+isInterfaceType _ = Nothing
+
+isUnionType :: forall m. Type m -> Maybe (UnionType m)
+isUnionType (NamedUnionType unionType) = Just unionType
+isUnionType (NonNullUnionType unionType) = Just unionType
+isUnionType _ = Nothing
+
 isListType :: forall m. Type m -> Maybe (Type m)
 isListType (ListType outputType) = Just outputType
 isListType (NonNullListType outputType) = Just outputType
@ -139,5 +187,7 @@ isNonNullType :: forall m. Type m -> Bool
 isNonNullType (NonNullScalarType _) = True
 isNonNullType (NonNullEnumType _) = True
 isNonNullType (NonNullObjectType _) = True
+isNonNullType (NonNullInterfaceType _) = True
+isNonNullType (NonNullUnionType _) = True
 isNonNullType (NonNullListType _) = True
 isNonNullType _ = False
--- a/src/Language/GraphQL/Type/Schema.hs
+++ b/src/Language/GraphQL/Type/Schema.hs
@ -20,6 +20,8 @@ data Type m
    | EnumType Definition.EnumType
    | ObjectType (Out.ObjectType m)
    | InputObjectType In.InputObjectType
+    | InterfaceType (Out.InterfaceType m)
+    | UnionType (Out.UnionType 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
@ -39,10 +41,9 @@ 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
+    collect traverser typeName element foundTypes
+        | HashMap.member typeName foundTypes = foundTypes
+        | otherwise = traverser $ HashMap.insert typeName element foundTypes
    visitFields (Out.Field _ outputType arguments _) foundTypes
        = traverseOutputType outputType
        $ foldr visitArguments foundTypes arguments
@ -63,6 +64,12 @@ collectReferencedTypes schema =
         in collect Prelude.id typeName (EnumType enumType)
    traverseOutputType (Out.ObjectBaseType objectType) =
        traverseObjectType objectType
+    traverseOutputType (Out.InterfaceBaseType interfaceType) =
+        traverseInterfaceType interfaceType
+    traverseOutputType (Out.UnionBaseType unionType) =
+        let (Out.UnionType typeName _ types) = unionType
+            traverser = flip (foldr traverseObjectType) types
+         in collect traverser typeName (UnionType unionType)
    traverseOutputType (Out.ListBaseType listType) =
        traverseOutputType listType
    traverseOutputType (Out.ScalarBaseType scalarType) =
@ -72,7 +79,15 @@ collectReferencedTypes schema =
        let (Definition.EnumType typeName _ _) = enumType
         in collect Prelude.id typeName (EnumType enumType)
    traverseObjectType objectType foundTypes =
-        let (Out.ObjectType typeName _ objectFields) = objectType
+        let (Out.ObjectType typeName _ interfaces fields) = objectType
            element = ObjectType objectType
-            traverser = flip (foldr visitFields) objectFields
+            traverser = polymorphicTypeTraverser 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
+         in collect traverser typeName element foundTypes
+    polymorphicTypeTraverser interfaces fields
+        = flip (foldr visitFields) fields
+        . flip (foldr traverseInterfaceType) interfaces
--- a/tests/Test/DirectiveSpec.hs
+++ b/tests/Test/DirectiveSpec.hs
@ -17,7 +17,7 @@ experimentalResolver :: Schema IO
 experimentalResolver = Schema { query = queryType, mutation = Nothing }
  where
    resolver = pure $ Out.Int 5
-    queryType = Out.ObjectType "Query" Nothing
+    queryType = Out.ObjectType "Query" Nothing []
        $ HashMap.singleton "experimentalField"
        $ Out.Field Nothing (Out.NamedScalarType int) mempty resolver

--- a/tests/Test/FragmentSpec.hs
+++ b/tests/Test/FragmentSpec.hs
@ -51,14 +51,14 @@ hasErrors (Object object') = HashMap.member "errors" object'
 hasErrors _ = True

 shirtType :: Out.ObjectType IO
-shirtType = Out.ObjectType "Shirt" Nothing
+shirtType = Out.ObjectType "Shirt" Nothing []
    $ HashMap.singleton resolverName
    $ Out.Field Nothing (Out.NamedScalarType string) mempty resolve
  where
    (Schema.Resolver resolverName resolve) = size

 hatType :: Out.ObjectType IO
-hatType = Out.ObjectType "Hat" Nothing
+hatType = Out.ObjectType "Hat" Nothing []
    $ HashMap.singleton resolverName
    $ Out.Field Nothing (Out.NamedScalarType int) mempty resolve
  where
@ -69,7 +69,7 @@ toSchema (Schema.Resolver resolverName resolve) = Schema
    { query = queryType, mutation = Nothing }
  where
    unionMember = if resolverName == "Hat" then hatType else shirtType
-    queryType = Out.ObjectType "Query" Nothing
+    queryType = Out.ObjectType "Query" Nothing []
        $ HashMap.singleton resolverName
        $ Out.Field Nothing (Out.NamedObjectType unionMember) mempty resolve

--- a/tests/Test/RootOperationSpec.hs
+++ b/tests/Test/RootOperationSpec.hs
@ -15,7 +15,7 @@ import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Type.Schema

 hatType :: Out.ObjectType IO
-hatType = Out.ObjectType "Hat" Nothing
+hatType = Out.ObjectType "Hat" Nothing []
    $ HashMap.singleton resolverName
    $ Out.Field Nothing (Out.NamedScalarType int) mempty resolve
  where
@ -24,8 +24,8 @@ hatType = Out.ObjectType "Hat" Nothing

 schema :: Schema IO
 schema = Schema
-    (Out.ObjectType "Query" Nothing hatField)
-    (Just $ Out.ObjectType "Mutation" Nothing incrementField)
+    (Out.ObjectType "Query" Nothing [] hatField)
+    (Just $ Out.ObjectType "Mutation" Nothing [] incrementField)
  where
    garment = pure $ Schema.object
        [ Schema.Resolver "circumference" $ pure $ Out.Int 60
--- a/tests/Test/StarWars/Schema.hs
+++ b/tests/Test/StarWars/Schema.hs
@ -25,7 +25,7 @@ import Test.StarWars.Data
 schema :: Schema Identity
 schema = Schema { query = queryType, mutation = Nothing }
  where
-    queryType = Out.ObjectType "Query" Nothing $ HashMap.fromList
+    queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
        [ ("hero", Out.Field Nothing (Out.NamedScalarType string) mempty hero)
        , ("human", Out.Field Nothing (Out.NamedScalarType string) mempty human)
        , ("droid", Out.Field Nothing (Out.NamedScalarType string) mempty droid)