From c7d5b02911380583ea8ca4bfc600f533658ab16f Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Sat, 19 Oct 2019 10:00:25 +0200
Subject: [PATCH] Handle top-level fragments

Fixes #17.
---
 package.yaml                          |  3 +--
 src/Language/GraphQL/AST/Transform.hs | 32 +++++++++++++--------------
 stack.yaml                            |  2 +-
 tests/Test/FragmentSpec.hs            | 18 +++++++++++++--
 4 files changed, 34 insertions(+), 21 deletions(-)

diff --git a/package.yaml b/package.yaml
index 40b5d04..3f4d823 100644
--- a/package.yaml
+++ b/package.yaml
@@ -31,11 +31,10 @@ dependencies:
 - megaparsec
 - text
 - transformers
+- unordered-containers
 
 library:
   source-dirs: src
-  dependencies:
-  - unordered-containers
 
 tests:
   tasty:
diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/AST/Transform.hs
index 53f04cd..3aa31b0 100644
--- a/src/Language/GraphQL/AST/Transform.hs
+++ b/src/Language/GraphQL/AST/Transform.hs
@@ -8,10 +8,10 @@ module Language.GraphQL.AST.Transform
     ) where
 
 import Control.Applicative (empty)
-import Control.Monad ((<=<))
 import Data.Bifunctor (first)
 import Data.Either (partitionEithers)
 import Data.Foldable (fold, foldMap)
+import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as NonEmpty
 import Data.Monoid (Alt(Alt,getAlt), (<>))
 import qualified Language.GraphQL.AST as Full
@@ -44,22 +44,20 @@ operations
   -> Fragmenter
   -> [Full.OperationDefinition]
   -> Maybe Core.Document
-operations subs fr = NonEmpty.nonEmpty <=< traverse (operation subs fr)
+operations subs fr = NonEmpty.nonEmpty . fmap (operation subs fr)
 
 operation
   :: Schema.Subs
   -> Fragmenter
   -> Full.OperationDefinition
-  -> Maybe Core.Operation
+  -> Core.Operation
 operation subs fr (Full.OperationSelectionSet sels) =
   operation subs fr $ Full.OperationDefinition Full.Query empty empty empty sels
 -- TODO: Validate Variable definitions with substituter
-operation subs fr (Full.OperationDefinition operationType name _vars _dirs sels)
-    = case operationType of
-        Full.Query -> Core.Query name <$> node
-        Full.Mutation -> Core.Mutation name <$> node
-  where
-    node = traverse (hush . selection subs fr) sels
+operation subs fr (Full.OperationDefinition Full.Query name _vars _dirs sels) =
+    Core.Query name $ appendSelection subs fr sels
+operation subs fr (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =
+    Core.Mutation name $ appendSelection subs fr sels
 
 selection
   :: Schema.Subs
@@ -75,12 +73,9 @@ selection subs fr  (Full.SelectionInlineFragment fragment)
         = Right
         $ Core.SelectionFragment
         $ Core.Fragment typeCondition
-        $ NonEmpty.fromList
-        $ appendSelection selectionSet
+        $ appendSelection subs fr selectionSet
     | (Full.InlineFragment Nothing _ selectionSet) <- fragment
-        = Left $ appendSelection selectionSet
-  where
-    appendSelection = foldr (either (++) (:) . selection subs fr) []
+        = Left $ NonEmpty.toList $ appendSelection subs fr selectionSet
 
 -- * Fragment replacement
 
@@ -132,5 +127,10 @@ value subs (Full.ValueObject   o) =
 objectField :: Schema.Subs -> Full.ObjectField -> Maybe Core.ObjectField
 objectField subs (Full.ObjectField n v) = Core.ObjectField n <$> value subs v
 
-hush :: Either a b -> Maybe b
-hush = either (const Nothing) Just
+appendSelection ::
+    Schema.Subs ->
+    Fragmenter ->
+    NonEmpty Full.Selection ->
+    NonEmpty Core.Selection
+appendSelection subs fr = NonEmpty.fromList
+    . foldr (either (++) (:) . selection subs fr) []
diff --git a/stack.yaml b/stack.yaml
index 44526e2..a376148 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,4 +1,4 @@
-resolver: lts-14.8
+resolver: lts-14.10
 
 packages:
 - .
diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs
index 337db7e..7b2bb92 100644
--- a/tests/Test/FragmentSpec.hs
+++ b/tests/Test/FragmentSpec.hs
@@ -4,12 +4,13 @@ module Test.FragmentSpec
     ( spec
     ) where
 
-import Data.Aeson (object, (.=))
+import Data.Aeson (Value(..), object, (.=))
+import qualified Data.HashMap.Strict as HashMap
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.Text (Text)
 import Language.GraphQL
 import qualified Language.GraphQL.Schema as Schema
-import Test.Hspec (Spec, describe, it, shouldBe)
+import Test.Hspec (Spec, describe, it, shouldBe, shouldNotSatisfy)
 import Text.RawString.QQ (r)
 
 size :: Schema.Resolver IO
@@ -81,3 +82,16 @@ spec = describe "Inline fragment executor" $ do
                     ]
                 ]
          in actual `shouldBe` expected
+
+    it "evaluates fragments on Query" $ do
+        let query = [r|{
+          ... {
+            size
+          }
+        }|]
+
+        actual <- graphql (size :| []) query
+        actual `shouldNotSatisfy` hasErrors
+      where
+        hasErrors (Object object') = HashMap.member "errors" object'
+        hasErrors _ = True