From c06d0b8e95ea4b87eab69da085cb32dbd052c1f0 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Tue, 26 May 2020 11:13:55 +0200 Subject: [PATCH] Add Union and Interface type definitions --- CHANGELOG.md | 16 +- docs/tutorial/tutorial.lhs | 6 +- src/Language/GraphQL/Execute.hs | 45 +++--- src/Language/GraphQL/Execute/Transform.hs | 187 +++++++++++++--------- src/Language/GraphQL/Type.hs | 2 + src/Language/GraphQL/Type/Out.hs | 54 ++++++- src/Language/GraphQL/Type/Schema.hs | 27 +++- tests/Test/DirectiveSpec.hs | 2 +- tests/Test/FragmentSpec.hs | 6 +- tests/Test/RootOperationSpec.hs | 6 +- tests/Test/StarWars/Schema.hs | 2 +- 11 files changed, 229 insertions(+), 124 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 8c813ec..6846a5a 100644 --- 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 diff --git a/docs/tutorial/tutorial.lhs b/docs/tutorial/tutorial.lhs index e80e8c7..39e151c 100644 --- 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) > ] 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 - 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' 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 diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs index 9ff8d8c..67264c2 100644 --- 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 diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index 2fb12d2..1f765a4 100644 --- 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 diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs index a20dc51..291b5f2 100644 --- 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 diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index f32c031..e58d33b 100644 --- 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)