From 86a0e00f7e9ecfcd3e641af8a05b69dd53143d88 Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Tue, 17 Nov 2020 08:10:32 +0100
Subject: Collect interface implementations

---
 src/Language/GraphQL/Type/Internal.hs | 16 +++++++++++-----
 src/Language/GraphQL/Type/Schema.hs   | 22 +++++++++++++++++++++-
 2 files changed, 32 insertions(+), 6 deletions(-)

(limited to 'src')

diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs
index 3861365..2081b97 100644
--- a/src/Language/GraphQL/Type/Internal.hs
+++ b/src/Language/GraphQL/Type/Internal.hs
@@ -14,6 +14,7 @@ module Language.GraphQL.Type.Internal
     , Type(..)
     , directives
     , doesFragmentTypeApply
+    , implementations
     , instanceOf
     , lookupCompositeField
     , lookupInputType
@@ -64,26 +65,31 @@ data Schema m = Schema
     (Maybe (Out.ObjectType m))
     Directives
     (HashMap Full.Name (Type m))
+    (HashMap Full.Name [Type m])
 
 -- | 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'
 
 -- | 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 099c256..dae8e18 100644
--- a/src/Language/GraphQL/Type/Schema.hs
+++ b/src/Language/GraphQL/Type/Schema.hs
@@ -23,6 +23,7 @@ import Language.GraphQL.Type.Internal
     , Schema
     , Type(..)
     , directives
+    , implementations
     , mutation
     , subscription
     , query
@@ -41,9 +42,11 @@ schema :: forall m
     -> Directives -- ^ Directive definitions.
     -> Schema m -- ^ Schema.
 schema queryRoot mutationRoot subscriptionRoot directiveDefinitions =
-    Internal.Schema queryRoot mutationRoot subscriptionRoot allDirectives collectedTypes
+    Internal.Schema queryRoot mutationRoot subscriptionRoot
+        allDirectives collectedTypes collectedImplementations
   where
     collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot
+    collectedImplementations = collectImplementations collectedTypes
     allDirectives = HashMap.union directiveDefinitions defaultDirectives
     defaultDirectives = HashMap.fromList
         [ ("skip", skipDirective)
@@ -153,3 +156,20 @@ collectReferencedTypes queryRoot mutationRoot subscriptionRoot =
     polymorphicTraverser interfaces fields
         = flip (foldr visitFields) fields
         . flip (foldr traverseInterfaceType) interfaces
+
+-- | Looks for objects and interfaces under the schema types and collects the
+-- interfaces they implement.
+collectImplementations :: forall m
+    . HashMap Full.Name (Type m)
+    -> HashMap Full.Name [Type m]
+collectImplementations = HashMap.foldr go HashMap.empty
+  where
+    go implementation@(InterfaceType interfaceType) accumulator =
+        let Out.InterfaceType _ _ interfaces _ = interfaceType
+         in foldr (add implementation) accumulator interfaces
+    go implementation@(ObjectType objectType) accumulator =
+        let Out.ObjectType _ _ interfaces _ = objectType
+         in foldr (add implementation) accumulator interfaces
+    go _ accumulator = accumulator
+    add implementation (Out.InterfaceType typeName _ _ _) accumulator =
+        HashMap.insertWith (++) typeName [implementation] accumulator
-- 
cgit v1.2.3