Add constructor with additional schema types

5 files changed, 119 insertions, 35 deletions

diff --git a/CHANGELOG.md b/CHANGELOG.md
index b18668a..174e6dc 100644
--- 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.
diff --git a/src/Language/GraphQL/Type.hs b/src/Language/GraphQL/Type.hs
index 3ed8bb9..8a2a4d1 100644
--- 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
diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs
index 2081b97..ce3b121 100644
--- 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
diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs
index dae8e18..ddddb4a 100644
--- 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
diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs
index 5035ec8..f5bfd33 100644
--- 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