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: [PATCH] Collect interface implementations

---
 CHANGELOG.md                          |  2 ++
 src/Language/GraphQL/Type/Internal.hs | 16 +++++++++++-----
 src/Language/GraphQL/Type/Schema.hs   | 22 +++++++++++++++++++++-
 stack.yaml                            |  2 +-
 4 files changed, 35 insertions(+), 7 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 9854006..49701e8 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -10,6 +10,8 @@ and this project adheres to
 ### Added
 - `Validate.Rules`:
   - `overlappingFieldsCanBeMergedRule`
+- `Type.Schema.implementations` contains a map from interfaces and objects to
+  interfaces they implement.
 
 ## [0.11.0.0] - 2020-11-07
 ### Changed
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
diff --git a/stack.yaml b/stack.yaml
index 7346efb..a4a98e4 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,4 +1,4 @@
-resolver: lts-16.21
+resolver: lts-16.22
 
 packages:
 - .