Add constructor with additional schema types
This commit is contained in:
parent
1b7cd85216
commit
c311cb0070
@ -10,6 +10,10 @@ and this project adheres to
|
|||||||
### Added
|
### Added
|
||||||
- `Language.GraphQL.Execute.OrderedMap` is a map data structure, that preserves
|
- `Language.GraphQL.Execute.OrderedMap` is a map data structure, that preserves
|
||||||
insertion order.
|
insertion order.
|
||||||
|
- `Language.GraphQL.Schema.schemaWithTypes` constructs a complete schema,
|
||||||
|
including an optional schema description and user-defined types not referenced
|
||||||
|
in the schema directly (for example interface implementations).
|
||||||
|
- `Language.GraphQL.Schema.description` returns the optional schema description.
|
||||||
|
|
||||||
### Fixed
|
### Fixed
|
||||||
- Parser now accepts empty lists and objects.
|
- Parser now accepts empty lists and objects.
|
||||||
|
@ -21,6 +21,6 @@ module Language.GraphQL.Type
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Language.GraphQL.Type.Definition
|
import Language.GraphQL.Type.Definition
|
||||||
import Language.GraphQL.Type.Schema (Schema, schema)
|
import Language.GraphQL.Type.Schema (Schema, schema, schemaWithTypes)
|
||||||
import qualified Language.GraphQL.Type.In as In
|
import qualified Language.GraphQL.Type.In as In
|
||||||
import qualified Language.GraphQL.Type.Out as Out
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
|
@ -12,6 +12,7 @@ module Language.GraphQL.Type.Internal
|
|||||||
, Directives
|
, Directives
|
||||||
, Schema(..)
|
, Schema(..)
|
||||||
, Type(..)
|
, Type(..)
|
||||||
|
, description
|
||||||
, directives
|
, directives
|
||||||
, doesFragmentTypeApply
|
, doesFragmentTypeApply
|
||||||
, implementations
|
, implementations
|
||||||
@ -55,41 +56,43 @@ type Directives = HashMap Full.Name Directive
|
|||||||
-- | A Schema is created by supplying the root types of each type of operation,
|
-- | 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
|
-- query and mutation (optional). A schema definition is then supplied to the
|
||||||
-- validator and executor.
|
-- 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
|
data Schema m = Schema
|
||||||
(Out.ObjectType m)
|
(Maybe Text) -- ^ Description.
|
||||||
(Maybe (Out.ObjectType m))
|
(Out.ObjectType m) -- ^ Query.
|
||||||
(Maybe (Out.ObjectType m))
|
(Maybe (Out.ObjectType m)) -- ^ Mutation.
|
||||||
Directives
|
(Maybe (Out.ObjectType m)) -- ^ Subscription.
|
||||||
(HashMap Full.Name (Type m))
|
Directives -- ^ Directives
|
||||||
|
(HashMap Full.Name (Type m)) -- ^ Types.
|
||||||
|
-- Interface implementations (used only for faster access).
|
||||||
(HashMap Full.Name [Type m])
|
(HashMap Full.Name [Type m])
|
||||||
|
|
||||||
|
-- | Schema description.
|
||||||
|
description :: forall m. Schema m -> Maybe Text
|
||||||
|
description (Schema description' _ _ _ _ _ _) = description'
|
||||||
|
|
||||||
-- | Schema query type.
|
-- | Schema query type.
|
||||||
query :: forall m. Schema m -> Out.ObjectType m
|
query :: forall m. Schema m -> Out.ObjectType m
|
||||||
query (Schema query' _ _ _ _ _) = query'
|
query (Schema _ query' _ _ _ _ _) = query'
|
||||||
|
|
||||||
-- | Schema mutation type.
|
-- | Schema mutation type.
|
||||||
mutation :: forall m. Schema m -> Maybe (Out.ObjectType m)
|
mutation :: forall m. Schema m -> Maybe (Out.ObjectType m)
|
||||||
mutation (Schema _ mutation' _ _ _ _) = mutation'
|
mutation (Schema _ _ mutation' _ _ _ _) = mutation'
|
||||||
|
|
||||||
-- | Schema subscription type.
|
-- | Schema subscription type.
|
||||||
subscription :: forall m. Schema m -> Maybe (Out.ObjectType m)
|
subscription :: forall m. Schema m -> Maybe (Out.ObjectType m)
|
||||||
subscription (Schema _ _ subscription' _ _ _) = subscription'
|
subscription (Schema _ _ _ subscription' _ _ _) = subscription'
|
||||||
|
|
||||||
-- | Schema directive definitions.
|
-- | Schema directive definitions.
|
||||||
directives :: forall m. Schema m -> Directives
|
directives :: forall m. Schema m -> Directives
|
||||||
directives (Schema _ _ _ directives' _ _) = directives'
|
directives (Schema _ _ _ _ directives' _ _) = directives'
|
||||||
|
|
||||||
-- | Types referenced by the schema.
|
-- | Types referenced by the schema.
|
||||||
types :: forall m. Schema m -> HashMap Full.Name (Type m)
|
types :: forall m. Schema m -> HashMap Full.Name (Type m)
|
||||||
types (Schema _ _ _ _ types' _) = types'
|
types (Schema _ _ _ _ _ types' _) = types'
|
||||||
|
|
||||||
-- | Interface implementations.
|
-- | Interface implementations.
|
||||||
implementations :: forall m. Schema m -> HashMap Full.Name [Type m]
|
implementations :: forall m. Schema m -> HashMap Full.Name [Type m]
|
||||||
implementations (Schema _ _ _ _ _ implementations') = implementations'
|
implementations (Schema _ _ _ _ _ _ implementations') = implementations'
|
||||||
|
|
||||||
-- | These types may describe the parent context of a selection set.
|
-- | These types may describe the parent context of a selection set.
|
||||||
data CompositeType m
|
data CompositeType m
|
||||||
|
@ -9,11 +9,13 @@
|
|||||||
-- functions for defining and manipulating schemas.
|
-- functions for defining and manipulating schemas.
|
||||||
module Language.GraphQL.Type.Schema
|
module Language.GraphQL.Type.Schema
|
||||||
( schema
|
( schema
|
||||||
|
, schemaWithTypes
|
||||||
, module Language.GraphQL.Type.Internal
|
, module Language.GraphQL.Type.Internal
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.HashMap.Strict (HashMap)
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
|
import Data.Text (Text)
|
||||||
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
|
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
|
||||||
import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
|
import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
|
||||||
import qualified Language.GraphQL.AST as Full
|
import qualified Language.GraphQL.AST as Full
|
||||||
@ -22,6 +24,7 @@ import Language.GraphQL.Type.Internal
|
|||||||
, Directives
|
, Directives
|
||||||
, Schema
|
, Schema
|
||||||
, Type(..)
|
, Type(..)
|
||||||
|
, description
|
||||||
, directives
|
, directives
|
||||||
, implementations
|
, implementations
|
||||||
, mutation
|
, mutation
|
||||||
@ -35,17 +38,47 @@ import qualified Language.GraphQL.Type.In as In
|
|||||||
import qualified Language.GraphQL.Type.Out as Out
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
|
|
||||||
-- | Schema constructor.
|
-- | Schema constructor.
|
||||||
|
--
|
||||||
|
-- __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 using 'schemaWithTypes' instead.
|
||||||
schema :: forall m
|
schema :: forall m
|
||||||
. Out.ObjectType m -- ^ Query type.
|
. Out.ObjectType m -- ^ Query type.
|
||||||
-> Maybe (Out.ObjectType m) -- ^ Mutation type.
|
-> Maybe (Out.ObjectType m) -- ^ Mutation type.
|
||||||
-> Maybe (Out.ObjectType m) -- ^ Subscription type.
|
-> Maybe (Out.ObjectType m) -- ^ Subscription type.
|
||||||
-> Directives -- ^ Directive definitions.
|
-> Directives -- ^ Directive definitions.
|
||||||
-> Schema m -- ^ Schema.
|
-> Schema m -- ^ Schema.
|
||||||
schema queryRoot mutationRoot subscriptionRoot directiveDefinitions =
|
schema queryRoot mutationRoot subscriptionRoot =
|
||||||
Internal.Schema queryRoot mutationRoot subscriptionRoot
|
schemaWithTypes Nothing queryRoot mutationRoot subscriptionRoot mempty
|
||||||
|
|
||||||
|
-- | Constructs a complete schema, including user-defined types not referenced
|
||||||
|
-- in the schema directly (for example interface implementations).
|
||||||
|
schemaWithTypes :: forall m
|
||||||
|
. Maybe Text -- ^ Schema description
|
||||||
|
-> Out.ObjectType m -- ^ Query type.
|
||||||
|
-> Maybe (Out.ObjectType m) -- ^ Mutation type.
|
||||||
|
-> Maybe (Out.ObjectType m) -- ^ Subscription type.
|
||||||
|
-> [Type m] -- ^ Additional types.
|
||||||
|
-> Directives -- ^ Directive definitions.
|
||||||
|
-> Schema m -- ^ Schema.
|
||||||
|
schemaWithTypes description' queryRoot mutationRoot subscriptionRoot types' directiveDefinitions =
|
||||||
|
Internal.Schema description' queryRoot mutationRoot subscriptionRoot
|
||||||
allDirectives collectedTypes collectedImplementations
|
allDirectives collectedTypes collectedImplementations
|
||||||
where
|
where
|
||||||
collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot
|
allTypes = foldr addTypeDefinition HashMap.empty types'
|
||||||
|
addTypeDefinition type'@(ScalarType (Definition.ScalarType typeName _)) accumulator =
|
||||||
|
HashMap.insert typeName type' accumulator
|
||||||
|
addTypeDefinition type'@(EnumType (Definition.EnumType typeName _ _)) accumulator =
|
||||||
|
HashMap.insert typeName type' accumulator
|
||||||
|
addTypeDefinition type'@(ObjectType (Out.ObjectType typeName _ _ _)) accumulator =
|
||||||
|
HashMap.insert typeName type' accumulator
|
||||||
|
addTypeDefinition type'@(InputObjectType (In.InputObjectType typeName _ _)) accumulator =
|
||||||
|
HashMap.insert typeName type' accumulator
|
||||||
|
addTypeDefinition type'@(InterfaceType (Out.InterfaceType typeName _ _ _)) accumulator =
|
||||||
|
HashMap.insert typeName type' accumulator
|
||||||
|
addTypeDefinition type'@(UnionType (Out.UnionType typeName _ _)) accumulator =
|
||||||
|
HashMap.insert typeName type' accumulator
|
||||||
|
collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot allTypes
|
||||||
collectedImplementations = collectImplementations collectedTypes
|
collectedImplementations = collectImplementations collectedTypes
|
||||||
allDirectives = HashMap.union directiveDefinitions defaultDirectives
|
allDirectives = HashMap.union directiveDefinitions defaultDirectives
|
||||||
defaultDirectives = HashMap.fromList
|
defaultDirectives = HashMap.fromList
|
||||||
@ -98,11 +131,12 @@ collectReferencedTypes :: forall m
|
|||||||
-> Maybe (Out.ObjectType m)
|
-> Maybe (Out.ObjectType m)
|
||||||
-> Maybe (Out.ObjectType m)
|
-> Maybe (Out.ObjectType m)
|
||||||
-> HashMap Full.Name (Type m)
|
-> HashMap Full.Name (Type m)
|
||||||
collectReferencedTypes queryRoot mutationRoot subscriptionRoot =
|
-> HashMap Full.Name (Type m)
|
||||||
let queryTypes = traverseObjectType queryRoot HashMap.empty
|
collectReferencedTypes queryRoot mutationRoot subscriptionRoot extraTypes =
|
||||||
|
let queryTypes = traverseObjectType queryRoot extraTypes
|
||||||
mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes)
|
mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes)
|
||||||
mutationRoot
|
mutationRoot
|
||||||
in maybe mutationTypes (`traverseObjectType` queryTypes) subscriptionRoot
|
in maybe mutationTypes (`traverseObjectType` mutationTypes) subscriptionRoot
|
||||||
where
|
where
|
||||||
collect traverser typeName element foundTypes
|
collect traverser typeName element foundTypes
|
||||||
| HashMap.member typeName foundTypes = foundTypes
|
| HashMap.member typeName foundTypes = foundTypes
|
||||||
|
@ -18,21 +18,29 @@ import qualified Data.HashMap.Strict as HashMap
|
|||||||
import Language.GraphQL.AST (Document, Location(..), Name)
|
import Language.GraphQL.AST (Document, Location(..), Name)
|
||||||
import Language.GraphQL.AST.Parser (document)
|
import Language.GraphQL.AST.Parser (document)
|
||||||
import Language.GraphQL.Error
|
import Language.GraphQL.Error
|
||||||
import Language.GraphQL.Execute
|
import Language.GraphQL.Execute (execute)
|
||||||
import Language.GraphQL.Type as Type
|
import qualified Language.GraphQL.Type.Schema as Schema
|
||||||
import Language.GraphQL.Type.Out as Out
|
import Language.GraphQL.Type
|
||||||
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
import Test.Hspec (Spec, context, describe, it, shouldBe)
|
import Test.Hspec (Spec, context, describe, it, shouldBe)
|
||||||
import Text.Megaparsec (parse)
|
import Text.Megaparsec (parse)
|
||||||
import Text.RawString.QQ (r)
|
import Text.RawString.QQ (r)
|
||||||
|
|
||||||
philosopherSchema :: Schema (Either SomeException)
|
philosopherSchema :: Schema (Either SomeException)
|
||||||
philosopherSchema = schema queryType Nothing (Just subscriptionType) mempty
|
philosopherSchema =
|
||||||
|
schemaWithTypes Nothing queryType Nothing subscriptionRoot extraTypes mempty
|
||||||
|
where
|
||||||
|
subscriptionRoot = Just subscriptionType
|
||||||
|
extraTypes =
|
||||||
|
[ Schema.ObjectType bookType
|
||||||
|
, Schema.ObjectType bookCollectionType
|
||||||
|
]
|
||||||
|
|
||||||
queryType :: Out.ObjectType (Either SomeException)
|
queryType :: Out.ObjectType (Either SomeException)
|
||||||
queryType = Out.ObjectType "Query" Nothing []
|
queryType = Out.ObjectType "Query" Nothing []
|
||||||
$ HashMap.singleton "philosopher"
|
$ HashMap.singleton "philosopher"
|
||||||
$ ValueResolver philosopherField
|
$ ValueResolver philosopherField
|
||||||
$ pure $ Type.Object mempty
|
$ pure $ Object mempty
|
||||||
where
|
where
|
||||||
philosopherField =
|
philosopherField =
|
||||||
Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
|
Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
|
||||||
@ -44,7 +52,7 @@ musicType = Out.ObjectType "Music" Nothing []
|
|||||||
resolvers =
|
resolvers =
|
||||||
[ ("instrument", ValueResolver instrumentField instrumentResolver)
|
[ ("instrument", ValueResolver instrumentField instrumentResolver)
|
||||||
]
|
]
|
||||||
instrumentResolver = pure $ Type.String "piano"
|
instrumentResolver = pure $ String "piano"
|
||||||
instrumentField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
instrumentField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||||
|
|
||||||
poetryType :: Out.ObjectType (Either SomeException)
|
poetryType :: Out.ObjectType (Either SomeException)
|
||||||
@ -54,7 +62,7 @@ poetryType = Out.ObjectType "Poetry" Nothing []
|
|||||||
resolvers =
|
resolvers =
|
||||||
[ ("genre", ValueResolver genreField genreResolver)
|
[ ("genre", ValueResolver genreField genreResolver)
|
||||||
]
|
]
|
||||||
genreResolver = pure $ Type.String "Futurism"
|
genreResolver = pure $ String "Futurism"
|
||||||
genreField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
genreField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||||
|
|
||||||
interestType :: Out.UnionType (Either SomeException)
|
interestType :: Out.UnionType (Either SomeException)
|
||||||
@ -69,27 +77,62 @@ philosopherType = Out.ObjectType "Philosopher" Nothing []
|
|||||||
, ("lastName", ValueResolver lastNameField lastNameResolver)
|
, ("lastName", ValueResolver lastNameField lastNameResolver)
|
||||||
, ("school", ValueResolver schoolField schoolResolver)
|
, ("school", ValueResolver schoolField schoolResolver)
|
||||||
, ("interest", ValueResolver interestField interestResolver)
|
, ("interest", ValueResolver interestField interestResolver)
|
||||||
|
, ("majorWork", ValueResolver majorWorkField majorWorkResolver)
|
||||||
]
|
]
|
||||||
firstNameField =
|
firstNameField =
|
||||||
Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||||
firstNameResolver = pure $ Type.String "Friedrich"
|
firstNameResolver = pure $ String "Friedrich"
|
||||||
lastNameField
|
lastNameField
|
||||||
= Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
= Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||||
lastNameResolver = pure $ Type.String "Nietzsche"
|
lastNameResolver = pure $ String "Nietzsche"
|
||||||
schoolField
|
schoolField
|
||||||
= Out.Field Nothing (Out.NonNullEnumType schoolType) HashMap.empty
|
= Out.Field Nothing (Out.NonNullEnumType schoolType) HashMap.empty
|
||||||
schoolResolver = pure $ Type.Enum "EXISTENTIALISM"
|
schoolResolver = pure $ Enum "EXISTENTIALISM"
|
||||||
interestField
|
interestField
|
||||||
= Out.Field Nothing (Out.NonNullUnionType interestType) HashMap.empty
|
= Out.Field Nothing (Out.NonNullUnionType interestType) HashMap.empty
|
||||||
interestResolver = pure
|
interestResolver = pure
|
||||||
$ Type.Object
|
$ Object
|
||||||
$ HashMap.fromList [("instrument", "piano")]
|
$ HashMap.fromList [("instrument", "piano")]
|
||||||
|
majorWorkField
|
||||||
|
= Out.Field Nothing (Out.NonNullInterfaceType workType) HashMap.empty
|
||||||
|
majorWorkResolver = pure
|
||||||
|
$ Object
|
||||||
|
$ HashMap.fromList
|
||||||
|
[ ("title", "Also sprach Zarathustra: Ein Buch für Alle und Keinen")
|
||||||
|
]
|
||||||
|
|
||||||
|
workType :: Out.InterfaceType (Either SomeException)
|
||||||
|
workType = Out.InterfaceType "Work" Nothing []
|
||||||
|
$ HashMap.fromList fields
|
||||||
|
where
|
||||||
|
fields = [("title", titleField)]
|
||||||
|
titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||||
|
|
||||||
|
bookType :: Out.ObjectType (Either SomeException)
|
||||||
|
bookType = Out.ObjectType "Book" Nothing [workType]
|
||||||
|
$ HashMap.fromList resolvers
|
||||||
|
where
|
||||||
|
resolvers =
|
||||||
|
[ ("title", ValueResolver titleField titleResolver)
|
||||||
|
]
|
||||||
|
titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||||
|
titleResolver = pure "Also sprach Zarathustra: Ein Buch für Alle und Keinen"
|
||||||
|
|
||||||
|
bookCollectionType :: Out.ObjectType (Either SomeException)
|
||||||
|
bookCollectionType = Out.ObjectType "Book" Nothing [workType]
|
||||||
|
$ HashMap.fromList resolvers
|
||||||
|
where
|
||||||
|
resolvers =
|
||||||
|
[ ("title", ValueResolver titleField titleResolver)
|
||||||
|
]
|
||||||
|
titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||||
|
titleResolver = pure "The Three Critiques"
|
||||||
|
|
||||||
subscriptionType :: Out.ObjectType (Either SomeException)
|
subscriptionType :: Out.ObjectType (Either SomeException)
|
||||||
subscriptionType = Out.ObjectType "Subscription" Nothing []
|
subscriptionType = Out.ObjectType "Subscription" Nothing []
|
||||||
$ HashMap.singleton "newQuote"
|
$ HashMap.singleton "newQuote"
|
||||||
$ EventStreamResolver quoteField (pure $ Type.Object mempty)
|
$ EventStreamResolver quoteField (pure $ Object mempty)
|
||||||
$ pure $ yield $ Type.Object mempty
|
$ pure $ yield $ Object mempty
|
||||||
where
|
where
|
||||||
quoteField =
|
quoteField =
|
||||||
Out.Field Nothing (Out.NonNullObjectType quoteType) HashMap.empty
|
Out.Field Nothing (Out.NonNullObjectType quoteType) HashMap.empty
|
||||||
|
Loading…
Reference in New Issue
Block a user