diff options
Diffstat (limited to 'src/Language')
| -rw-r--r-- | src/Language/GraphQL/Execute.hs | 45 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Transform.hs | 187 | ||||
| -rw-r--r-- | src/Language/GraphQL/Type.hs | 2 | ||||
| -rw-r--r-- | src/Language/GraphQL/Type/Out.hs | 54 | ||||
| -rw-r--r-- | src/Language/GraphQL/Type/Schema.hs | 27 |
5 files changed, 211 insertions, 104 deletions
diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 65ab6f7..862e360 100644 --- 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 diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index 849a646..8233c73 100644 --- 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 + + (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 - pure $ Document - $ operation fragmentTable coercedValues chosenOperation +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' diff --git a/src/Language/GraphQL/Type.hs b/src/Language/GraphQL/Type.hs index c6e8507..5dfd622 100644 --- 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 diff --git a/src/Language/GraphQL/Type/Out.hs b/src/Language/GraphQL/Type/Out.hs index b421f2e..fe2d4f2 100644 --- 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 diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs index 91096d3..74ab974 100644 --- 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 |