Add constructor with additional schema types

3 files changed, 59 insertions, 22 deletions

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