Add constructor with additional schema types

2021-05-13 17:40:38 +02:00 · 2021-05-13 17:40:38 +02:00 · c311cb0070
parent 1b7cd85216
commit c311cb0070
5 changed files with 119 additions and 35 deletions
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@ -10,6 +10,10 @@ and this project adheres to
 ### Added
 - `Language.GraphQL.Execute.OrderedMap` is a map data structure, that preserves
  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
 - Parser now accepts empty lists and objects.
--- a/src/Language/GraphQL/Type.hs
+++ b/src/Language/GraphQL/Type.hs
@ -21,6 +21,6 @@ module Language.GraphQL.Type
    ) where

 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.Out as Out
--- a/src/Language/GraphQL/Type/Internal.hs
+++ b/src/Language/GraphQL/Type/Internal.hs
@ -12,6 +12,7 @@ module Language.GraphQL.Type.Internal
    , Directives
    , Schema(..)
    , Type(..)
+    , description
    , directives
    , doesFragmentTypeApply
    , 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,
 --   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))
+    (Maybe Text) -- ^ Description.
+    (Out.ObjectType m) -- ^ Query.
+    (Maybe (Out.ObjectType m)) -- ^ Mutation.
+    (Maybe (Out.ObjectType m)) -- ^ Subscription.
+    Directives -- ^ Directives
+    (HashMap Full.Name (Type m)) -- ^ Types.
+    -- Interface implementations (used only for faster access).
    (HashMap Full.Name [Type m])

+-- | Schema description.
+description :: forall m. Schema m -> Maybe Text
+description (Schema description' _ _ _ _ _ _) = description'
+
 -- | Schema query type.
 query :: forall m. Schema m -> Out.ObjectType m
-query (Schema query' _ _ _ _ _) = query'
+query (Schema _ query' _ _ _ _ _) = query'

 -- | Schema mutation type.
 mutation :: forall m. Schema m -> Maybe (Out.ObjectType m)
-mutation (Schema _ mutation' _ _ _ _) = mutation'
+mutation (Schema _ _ mutation' _ _ _ _) = mutation'

 -- | Schema subscription type.
 subscription :: forall m. Schema m -> Maybe (Out.ObjectType m)
-subscription (Schema _ _ subscription' _ _ _) = subscription'
+subscription (Schema _ _ _ subscription' _ _ _) = subscription'

 -- | Schema directive definitions.
 directives :: forall m. Schema m -> Directives
-directives (Schema _ _ _ directives' _ _) = directives'
+directives (Schema _ _ _ _ directives' _ _) = directives'

 -- | Types referenced by the schema.
 types :: forall m. Schema m -> HashMap Full.Name (Type m)
-types (Schema _ _ _ _ types' _) = types'
+types (Schema _ _ _ _ _ types' _) = types'

 -- | Interface implementations.
 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.
 data CompositeType m
--- a/src/Language/GraphQL/Type/Schema.hs
+++ b/src/Language/GraphQL/Type/Schema.hs
@ -9,11 +9,13 @@
 -- functions for defining and manipulating schemas.
 module Language.GraphQL.Type.Schema
    ( schema
+    , schemaWithTypes
    , module Language.GraphQL.Type.Internal
    ) where

 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
+import Data.Text (Text)
 import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
 import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
 import qualified Language.GraphQL.AST as Full
@ -22,6 +24,7 @@ import Language.GraphQL.Type.Internal
    , Directives
    , Schema
    , Type(..)
+    , description
    , directives
    , implementations
    , mutation
@ -35,17 +38,47 @@ import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out

 -- | 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
    . 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
+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
  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
    allDirectives = HashMap.union directiveDefinitions defaultDirectives
    defaultDirectives = HashMap.fromList
@ -98,11 +131,12 @@ collectReferencedTypes :: forall m
    -> Maybe (Out.ObjectType m)
    -> Maybe (Out.ObjectType m)
    -> HashMap Full.Name (Type m)
-collectReferencedTypes queryRoot mutationRoot subscriptionRoot =
-    let queryTypes = traverseObjectType queryRoot HashMap.empty
+    -> HashMap Full.Name (Type m)
+collectReferencedTypes queryRoot mutationRoot subscriptionRoot extraTypes =
+    let queryTypes = traverseObjectType queryRoot extraTypes
        mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes)
            mutationRoot
-     in maybe mutationTypes (`traverseObjectType` queryTypes) subscriptionRoot
+     in maybe mutationTypes (`traverseObjectType` mutationTypes) subscriptionRoot
  where
    collect traverser typeName element foundTypes
        | HashMap.member typeName foundTypes = foundTypes
--- a/tests/Language/GraphQL/ExecuteSpec.hs
+++ b/tests/Language/GraphQL/ExecuteSpec.hs
@ -18,21 +18,29 @@ import qualified Data.HashMap.Strict as HashMap
 import Language.GraphQL.AST (Document, Location(..), Name)
 import Language.GraphQL.AST.Parser (document)
 import Language.GraphQL.Error
-import Language.GraphQL.Execute
-import Language.GraphQL.Type as Type
-import Language.GraphQL.Type.Out as Out
+import Language.GraphQL.Execute (execute)
+import qualified Language.GraphQL.Type.Schema as Schema
+import Language.GraphQL.Type
+import qualified Language.GraphQL.Type.Out as Out
 import Test.Hspec (Spec, context, describe, it, shouldBe)
 import Text.Megaparsec (parse)
 import Text.RawString.QQ (r)

 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 "Query" Nothing []
    $ HashMap.singleton "philosopher"
    $ ValueResolver philosopherField
-    $ pure $ Type.Object mempty
+    $ pure $ Object mempty
  where
    philosopherField =
        Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
@ -44,7 +52,7 @@ musicType = Out.ObjectType "Music" Nothing []
    resolvers =
        [ ("instrument", ValueResolver instrumentField instrumentResolver)
        ]
-    instrumentResolver = pure $ Type.String "piano"
+    instrumentResolver = pure $ String "piano"
    instrumentField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty

 poetryType :: Out.ObjectType (Either SomeException)
@ -54,7 +62,7 @@ poetryType = Out.ObjectType "Poetry" Nothing []
    resolvers =
        [ ("genre", ValueResolver genreField genreResolver)
        ]
-    genreResolver = pure $ Type.String "Futurism"
+    genreResolver = pure $ String "Futurism"
    genreField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty

 interestType :: Out.UnionType (Either SomeException)
@ -69,27 +77,62 @@ philosopherType = Out.ObjectType "Philosopher" Nothing []
        , ("lastName", ValueResolver lastNameField lastNameResolver)
        , ("school", ValueResolver schoolField schoolResolver)
        , ("interest", ValueResolver interestField interestResolver)
+        , ("majorWork", ValueResolver majorWorkField majorWorkResolver)
        ]
    firstNameField =
        Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
-    firstNameResolver = pure $ Type.String "Friedrich"
+    firstNameResolver = pure $ String "Friedrich"
    lastNameField
        = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
-    lastNameResolver = pure $ Type.String "Nietzsche"
+    lastNameResolver = pure $ String "Nietzsche"
    schoolField
       = Out.Field Nothing (Out.NonNullEnumType schoolType) HashMap.empty
-    schoolResolver = pure $ Type.Enum "EXISTENTIALISM"
+    schoolResolver = pure $ Enum "EXISTENTIALISM"
    interestField
        = Out.Field Nothing (Out.NonNullUnionType interestType) HashMap.empty
    interestResolver = pure
-        $ Type.Object
+        $ Object
        $ 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 "Subscription" Nothing []
    $ HashMap.singleton "newQuote"
-    $ EventStreamResolver quoteField (pure $ Type.Object mempty)
-    $ pure $ yield $ Type.Object mempty
+    $ EventStreamResolver quoteField (pure $ Object mempty)
+    $ pure $ yield $ Object mempty
  where
    quoteField =
        Out.Field Nothing (Out.NonNullObjectType quoteType) HashMap.empty