Handle top-level fragments

Fixes #17.

package.yaml

@@ -31,11 +31,10 @@ dependencies:
 - megaparsec
 - text
 - transformers
+- unordered-containers
 
 library:
   source-dirs: src
-  dependencies:
-  - unordered-containers
 
 tests:
   tasty:

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) []

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-14.8
+resolver: lts-14.10
 
 packages:
 - .

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