Support nested fragments

... without forward lookup.

CHANGELOG.md

@@ -17,6 +17,9 @@ All notable changes to this project will be documented in this file.
 - (Unsupported) nested fragments doesn't throw a runtime error but return a
   transformation error.
 
+### Added
+  - Nested fragments support without forward lookup.
+
 ## [0.5.1.0] - 2019-10-22
 ### Deprecated
 - `Language.GraphQL.AST.Arguments`. Use `[Language.GraphQL.AST.Argument]`

src/Language/GraphQL/AST/Transform.hs

@@ -19,7 +19,7 @@ import qualified Language.GraphQL.AST.Core as Core
 import qualified Language.GraphQL.Schema as Schema
 
 -- | Associates a fragment name with a list of 'Core.Field's.
-type Fragments = HashMap Core.Name (NonEmpty Core.Field)
+type Fragments = HashMap Core.Name (NonEmpty Core.Selection)
 
 data Replacement = Replacement
     { substitute :: Schema.Subs
@@ -31,11 +31,14 @@ type TransformT a = ReaderT Replacement Maybe a
 -- | Rewrites the original syntax tree into an intermediate representation used
 -- for query execution.
 document :: Schema.Subs -> Full.Document -> Maybe Core.Document
-document subs doc =
-    (runReaderT (operations operations') . Replacement subs) =<< fragments'
+document subs doc = do
+    fragmentMap <- foldr go (Just HashMap.empty) fragments'
+    runReaderT (operations operations') $ Replacement subs fragmentMap
   where
-    (fragments', operations') = foldr (defrag subs) (Just HashMap.empty, [])
-        $ NonEmpty.toList doc
+    (fragments', operations') = foldr defragment ([], []) doc
+    go fragDef (Just fragmentsMap) =
+        runReaderT (fragmentDefinition fragDef) (Replacement subs fragmentsMap)
+    go _ Nothing = Nothing
 
 -- * Operation
 
@@ -60,7 +63,7 @@ selection ::
 selection (Full.SelectionField fld) = Right . Core.SelectionField <$> field fld
 selection (Full.SelectionFragmentSpread (Full.FragmentSpread name _)) = do
     fragments' <- asks fragments
-    lift $ Left . fmap Core.SelectionField <$> HashMap.lookup name fragments'
+    lift $ Left <$> HashMap.lookup name fragments'
 selection (Full.SelectionInlineFragment fragment)
     | (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment
         = Right
@@ -73,31 +76,24 @@ selection (Full.SelectionInlineFragment fragment)
 -- * Fragment replacement
 
 -- | Extract fragments into a single 'HashMap' and operation definitions.
-defrag ::
-    Schema.Subs ->
+defragment ::
     Full.Definition ->
-    (Maybe Fragments, [Full.OperationDefinition]) ->
-    (Maybe Fragments, [Full.OperationDefinition])
-defrag _ (Full.DefinitionOperation op) (fragments', operations') =
+    ([Full.FragmentDefinition], [Full.OperationDefinition]) ->
+    ([Full.FragmentDefinition], [Full.OperationDefinition])
+defragment (Full.DefinitionOperation op) (fragments', operations') =
     (fragments', op : operations')
-defrag subs (Full.DefinitionFragment fragDef) (Just fragments', operations') =
-    (runReaderT (fragmentDefinition fragDef) (Replacement subs fragments'), operations')
-defrag _ _ (Nothing, operations') =
-    (Nothing, operations')
+defragment (Full.DefinitionFragment fragDef) (fragments', operations') =
+    (fragDef : fragments', operations')
 
 fragmentDefinition :: Full.FragmentDefinition -> TransformT Fragments
 fragmentDefinition (Full.FragmentDefinition name _tc _dirs sels) = do
-    emitted <- emitValue
-    newValue <- lift $ traverse extractField emitted
+    newValue <- emitValue
     fragments' <- asks fragments
     lift . Just $ HashMap.insert name newValue fragments'
   where
     emitValue = do
         selections <- traverse selection sels
         pure $ selections >>= either id pure
-    extractField :: Core.Selection -> Maybe Core.Field
-    extractField (Core.SelectionField field') = Just field'
-    extractField _ = Nothing -- Fragments within fragments are not supported yet
 
 field :: Full.Field -> TransformT Core.Field
 field (Full.Field a n args _dirs sels) = do

tests/Test/FragmentSpec.hs

@@ -91,7 +91,29 @@ spec = describe "Inline fragment executor" $ do
         }|]
 
         actual <- graphql (size :| []) query
-        actual `shouldNotSatisfy` hasErrors
-      where
-        hasErrors (Object object') = HashMap.member "errors" object'
-        hasErrors _ = True
+        let hasErrors (Object object') = HashMap.member "errors" object'
+            hasErrors _ = True
+         in actual `shouldNotSatisfy` hasErrors
+
+    it "evaluates nested fragments" $ do
+        let query = [r|
+          {
+            ...hatFragment
+          }
+
+          fragment hatFragment on Hat {
+            ...circumferenceFragment
+          }
+
+          fragment circumferenceFragment on Hat {
+            circumference
+          }
+        |]
+
+        actual <- graphql (circumference :| []) query
+        let expected = object
+                [ "data" .= object
+                    [ "circumference" .= (60 :: Int)
+                    ]
+                ]
+         in actual `shouldBe` expected