diff options
Diffstat (limited to 'src/Language/GraphQL/Type')
| -rw-r--r-- | src/Language/GraphQL/Type/Internal.hs | 169 | ||||
| -rw-r--r-- | src/Language/GraphQL/Type/Schema.hs | 183 |
2 files changed, 218 insertions, 134 deletions
diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs index 2aea996..eb8489c 100644 --- a/src/Language/GraphQL/Type/Internal.hs +++ b/src/Language/GraphQL/Type/Internal.hs @@ -8,22 +8,80 @@ module Language.GraphQL.Type.Internal ( AbstractType(..) , CompositeType(..) - , collectReferencedTypes + , Directive(..) + , Directives + , Schema(..) + , Type(..) + , directives , doesFragmentTypeApply , instanceOf , lookupInputType , lookupTypeCondition , lookupTypeField + , mutation + , subscription + , query + , types ) where import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.Text (Text) import qualified Language.GraphQL.AST as Full +import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation) import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out -import Language.GraphQL.Type.Schema (Schema) -import qualified Language.GraphQL.Type.Schema as Schema + +-- | These are all of the possible kinds of types. +data Type m + = ScalarType Definition.ScalarType + | EnumType Definition.EnumType + | ObjectType (Out.ObjectType m) + | InputObjectType In.InputObjectType + | InterfaceType (Out.InterfaceType m) + | UnionType (Out.UnionType m) + deriving Eq + +-- | Directive definition. +data Directive = Directive (Maybe Text) [DirectiveLocation] In.Arguments + +-- | Directive definitions. +type Directives = HashMap Full.Name Directive + +-- | 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. +-- +-- __Note:__ When the schema is constructed, by default only the types that +-- are reachable by traversing the root types are included, other types must +-- be explicitly referenced. +data Schema m = Schema + (Out.ObjectType m) + (Maybe (Out.ObjectType m)) + (Maybe (Out.ObjectType m)) + Directives + (HashMap Full.Name (Type m)) + +-- | Schema query type. +query :: forall m. Schema m -> Out.ObjectType m +query (Schema query' _ _ _ _) = query' + +-- | Schema mutation type. +mutation :: forall m. Schema m -> Maybe (Out.ObjectType m) +mutation (Schema _ mutation' _ _ _) = mutation' + +-- | Schema subscription type. +subscription :: forall m. Schema m -> Maybe (Out.ObjectType m) +subscription (Schema _ _ subscription' _ _) = subscription' + +-- | Schema directive definitions. +directives :: forall m. Schema m -> Directives +directives (Schema _ _ _ directives' _) = directives' + +-- | Types referenced by the schema. +types :: forall m. Schema m -> HashMap Full.Name (Type m) +types (Schema _ _ _ _ types') = types' -- | These types may describe the parent context of a selection set. data CompositeType m @@ -38,70 +96,6 @@ data AbstractType m | AbstractInterfaceType (Out.InterfaceType m) deriving Eq --- | Traverses the schema and finds all referenced types. -collectReferencedTypes :: forall m - . Schema m - -> HashMap Full.Name (Schema.Type m) -collectReferencedTypes schema = - let queryTypes = traverseObjectType (Schema.query schema) HashMap.empty - mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes) - $ Schema.mutation schema - in maybe mutationTypes (`traverseObjectType` queryTypes) - $ Schema.subscription schema - where - 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 - visitArguments (In.Argument _ inputType _) = traverseInputType inputType - visitInputFields (In.InputField _ inputType _) = traverseInputType inputType - getField (Out.ValueResolver field _) = field - getField (Out.EventStreamResolver field _ _) = field - traverseInputType (In.InputObjectBaseType objectType) = - let In.InputObjectType typeName _ inputFields = objectType - element = Schema.InputObjectType objectType - traverser = flip (foldr visitInputFields) inputFields - in collect traverser typeName element - traverseInputType (In.ListBaseType listType) = - traverseInputType listType - traverseInputType (In.ScalarBaseType scalarType) = - let Definition.ScalarType typeName _ = scalarType - in collect Prelude.id typeName (Schema.ScalarType scalarType) - traverseInputType (In.EnumBaseType enumType) = - let Definition.EnumType typeName _ _ = enumType - in collect Prelude.id typeName (Schema.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 (Schema.UnionType unionType) - traverseOutputType (Out.ListBaseType listType) = - traverseOutputType listType - traverseOutputType (Out.ScalarBaseType scalarType) = - let Definition.ScalarType typeName _ = scalarType - in collect Prelude.id typeName (Schema.ScalarType scalarType) - traverseOutputType (Out.EnumBaseType enumType) = - let Definition.EnumType typeName _ _ = enumType - in collect Prelude.id typeName (Schema.EnumType enumType) - traverseObjectType objectType foundTypes = - let Out.ObjectType typeName _ interfaces fields = objectType - element = Schema.ObjectType objectType - traverser = polymorphicTraverser interfaces (getField <$> fields) - in collect traverser typeName element foundTypes - traverseInterfaceType interfaceType foundTypes = - let Out.InterfaceType typeName _ interfaces fields = interfaceType - element = Schema.InterfaceType interfaceType - traverser = polymorphicTraverser interfaces fields - in collect traverser typeName element foundTypes - polymorphicTraverser interfaces fields - = flip (foldr visitFields) fields - . flip (foldr traverseInterfaceType) interfaces - doesFragmentTypeApply :: forall m . CompositeType m -> Out.ObjectType m @@ -128,45 +122,42 @@ instanceOf objectType (AbstractUnionType unionType) = lookupTypeCondition :: forall m . Full.Name - -> HashMap Full.Name (Schema.Type m) + -> HashMap Full.Name (Type m) -> Maybe (CompositeType m) lookupTypeCondition type' types' = case HashMap.lookup type' types' of - Just (Schema.ObjectType objectType) -> + Just (ObjectType objectType) -> Just $ CompositeObjectType objectType - Just (Schema.UnionType unionType) -> Just $ CompositeUnionType unionType - Just (Schema.InterfaceType interfaceType) -> + Just (UnionType unionType) -> Just $ CompositeUnionType unionType + Just (InterfaceType interfaceType) -> Just $ CompositeInterfaceType interfaceType _ -> Nothing -lookupInputType - :: Full.Type - -> HashMap.HashMap Full.Name (Schema.Type m) - -> Maybe In.Type -lookupInputType (Full.TypeNamed name) types = - case HashMap.lookup name types of - Just (Schema.ScalarType scalarType) -> +lookupInputType :: Full.Type -> HashMap Full.Name (Type m) -> Maybe In.Type +lookupInputType (Full.TypeNamed name) types' = + case HashMap.lookup name types' of + Just (ScalarType scalarType) -> Just $ In.NamedScalarType scalarType - Just (Schema.EnumType enumType) -> + Just (EnumType enumType) -> Just $ In.NamedEnumType enumType - Just (Schema.InputObjectType objectType) -> + Just (InputObjectType objectType) -> Just $ In.NamedInputObjectType objectType _ -> Nothing -lookupInputType (Full.TypeList list) types +lookupInputType (Full.TypeList list) types' = In.ListType - <$> lookupInputType list types -lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types = - case HashMap.lookup nonNull types of - Just (Schema.ScalarType scalarType) -> + <$> lookupInputType list types' +lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types' = + case HashMap.lookup nonNull types' of + Just (ScalarType scalarType) -> Just $ In.NonNullScalarType scalarType - Just (Schema.EnumType enumType) -> + Just (EnumType enumType) -> Just $ In.NonNullEnumType enumType - Just (Schema.InputObjectType objectType) -> + Just (InputObjectType objectType) -> Just $ In.NonNullInputObjectType objectType _ -> Nothing -lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types +lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types' = In.NonNullListType - <$> lookupInputType nonNull types + <$> lookupInputType nonNull types' lookupTypeField :: forall a. Full.Name -> Out.Type a -> Maybe (Out.Field a) lookupTypeField fieldName = \case diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs index 6562fb5..099c256 100644 --- a/src/Language/GraphQL/Type/Schema.hs +++ b/src/Language/GraphQL/Type/Schema.hs @@ -3,60 +3,153 @@ obtain one at https://mozilla.org/MPL/2.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.Type.Schema - ( Directive(..) - , Directives - , Schema(..) - , Type(..) - , schema + ( schema + , module Language.GraphQL.Type.Internal ) where import Data.HashMap.Strict (HashMap) -import Data.Text (Text) -import qualified Language.GraphQL.AST.Document as Full -import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation) +import qualified Data.HashMap.Strict as HashMap +import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..)) +import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation +import qualified Language.GraphQL.AST as Full +import Language.GraphQL.Type.Internal + ( Directive(..) + , Directives + , Schema + , Type(..) + , directives + , mutation + , subscription + , query + , types + ) import qualified Language.GraphQL.Type.Definition as Definition +import qualified Language.GraphQL.Type.Internal as Internal import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out --- | These are all of the possible kinds of types. -data Type m - = ScalarType Definition.ScalarType - | EnumType Definition.EnumType - | ObjectType (Out.ObjectType m) - | InputObjectType In.InputObjectType - | InterfaceType (Out.InterfaceType m) - | UnionType (Out.UnionType m) - deriving Eq - --- | Directive definition. -data Directive = Directive (Maybe Text) [DirectiveLocation] In.Arguments - --- | Directive definitions. -type Directives = HashMap Full.Name Directive - --- | 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. --- --- __Note:__ When the schema is constructed, by default only the types that --- are reachable by traversing the root types are included, other types must --- be explicitly referenced. -data Schema m = Schema - { query :: Out.ObjectType m - , mutation :: Maybe (Out.ObjectType m) - , subscription :: Maybe (Out.ObjectType m) - , directives :: Directives - } +-- | Schema constructor. +schema :: forall m + . Out.ObjectType m -- ^ Query type. + -> Maybe (Out.ObjectType m) -- ^ Mutation type. + -> Maybe (Out.ObjectType m) -- ^ Subscription type. + -> Directives -- ^ Directive definitions. + -> Schema m -- ^ Schema. +schema queryRoot mutationRoot subscriptionRoot directiveDefinitions = + Internal.Schema queryRoot mutationRoot subscriptionRoot allDirectives collectedTypes + where + collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot + allDirectives = HashMap.union directiveDefinitions defaultDirectives + defaultDirectives = HashMap.fromList + [ ("skip", skipDirective) + , ("include", includeDirective) + , ("deprecated", deprecatedDirective) + ] + includeDirective = + Directive includeDescription skipIncludeLocations includeArguments + includeArguments = HashMap.singleton "if" + $ In.Argument (Just "Included when true.") ifType Nothing + includeDescription = Just + "Directs the executor to include this field or fragment only when the \ + \`if` argument is true." + skipDirective = Directive skipDescription skipIncludeLocations skipArguments + skipArguments = HashMap.singleton "if" + $ In.Argument (Just "skipped when true.") ifType Nothing + ifType = In.NonNullScalarType Definition.boolean + skipDescription = Just + "Directs the executor to skip this field or fragment when the `if` \ + \argument is true." + skipIncludeLocations = + [ ExecutableDirectiveLocation DirectiveLocation.Field + , ExecutableDirectiveLocation DirectiveLocation.FragmentSpread + , ExecutableDirectiveLocation DirectiveLocation.InlineFragment + ] + deprecatedDirective = + Directive deprecatedDescription deprecatedLocations deprecatedArguments + reasonDescription = Just + "Explains why this element was deprecated, usually also including a \ + \suggestion for how to access supported similar data. Formatted using \ + \the Markdown syntax, as specified by \ + \[CommonMark](https://commonmark.org/).'" + deprecatedArguments = HashMap.singleton "reason" + $ In.Argument reasonDescription reasonType + $ Just "No longer supported" + reasonType = In.NamedScalarType Definition.string + deprecatedDescription = Just + "Marks an element of a GraphQL schema as no longer supported." + deprecatedLocations = + [ TypeSystemDirectiveLocation DirectiveLocation.FieldDefinition + , TypeSystemDirectiveLocation DirectiveLocation.ArgumentDefinition + , TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition + , TypeSystemDirectiveLocation DirectiveLocation.EnumValue + ] --- | Shortcut for creating a schema. -schema :: forall m. Out.ObjectType m -> Schema m -schema query' = Schema - { query = query' - , mutation = Nothing - , subscription = Nothing - , directives = mempty - } +-- | Traverses the schema and finds all referenced types. +collectReferencedTypes :: forall m + . Out.ObjectType m + -> Maybe (Out.ObjectType m) + -> Maybe (Out.ObjectType m) + -> HashMap Full.Name (Type m) +collectReferencedTypes queryRoot mutationRoot subscriptionRoot = + let queryTypes = traverseObjectType queryRoot HashMap.empty + mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes) + mutationRoot + in maybe mutationTypes (`traverseObjectType` queryTypes) subscriptionRoot + where + 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 + visitArguments (In.Argument _ inputType _) = traverseInputType inputType + visitInputFields (In.InputField _ inputType _) = traverseInputType inputType + getField (Out.ValueResolver field _) = field + getField (Out.EventStreamResolver field _ _) = field + traverseInputType (In.InputObjectBaseType objectType) = + let In.InputObjectType typeName _ inputFields = objectType + element = InputObjectType objectType + traverser = flip (foldr visitInputFields) inputFields + in collect traverser typeName element + traverseInputType (In.ListBaseType listType) = + traverseInputType listType + traverseInputType (In.ScalarBaseType scalarType) = + let Definition.ScalarType typeName _ = scalarType + in collect Prelude.id typeName (ScalarType scalarType) + traverseInputType (In.EnumBaseType enumType) = + let Definition.EnumType typeName _ _ = enumType + 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) = + let Definition.ScalarType typeName _ = scalarType + in collect Prelude.id typeName (ScalarType scalarType) + traverseOutputType (Out.EnumBaseType enumType) = + let Definition.EnumType typeName _ _ = enumType + in collect Prelude.id typeName (EnumType enumType) + traverseObjectType objectType foundTypes = + let Out.ObjectType typeName _ interfaces fields = objectType + element = ObjectType objectType + traverser = polymorphicTraverser interfaces (getField <$> fields) + in collect traverser typeName element foundTypes + traverseInterfaceType interfaceType foundTypes = + let Out.InterfaceType typeName _ interfaces fields = interfaceType + element = InterfaceType interfaceType + traverser = polymorphicTraverser interfaces fields + in collect traverser typeName element foundTypes + polymorphicTraverser interfaces fields + = flip (foldr visitFields) fields + . flip (foldr traverseInterfaceType) interfaces |