From 37254c8c9532794ed41570ef8c646c41e7044f2c Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Fri, 11 Oct 2019 23:28:55 +0200
Subject: [PATCH] Inline fragments without type

Fixes #11.
---
 CHANGELOG.md                          |  1 +
 src/Language/GraphQL/AST/Transform.hs | 26 +++++++++++++-------------
 stack.yaml                            |  2 +-
 tests/Test/FragmentSpec.hs            | 22 ++++++++++++++++++++++
 4 files changed, 37 insertions(+), 14 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 612fc1a..8a11fcc 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -12,6 +12,7 @@ All notable changes to this project will be documented in this file.
 
 ### Added
 - Module documentation.
+- Inline fragment support.
 
 ## [0.5.0.1] - 2019-09-10
 ### Added
diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/AST/Transform.hs
index 4b82082..53f04cd 100644
--- a/src/Language/GraphQL/AST/Transform.hs
+++ b/src/Language/GraphQL/AST/Transform.hs
@@ -66,20 +66,21 @@ selection
   -> Fragmenter
   -> Full.Selection
   -> Either [Core.Selection] Core.Selection
-selection subs fr (Full.SelectionField fld) =
-  Right $ Core.SelectionField $ field subs fr fld
-selection _    fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) =
-  Left $ Core.SelectionField <$> fr n
+selection subs fr (Full.SelectionField fld)
+    = Right $ Core.SelectionField $ field subs fr fld
+selection _ fr (Full.SelectionFragmentSpread (Full.FragmentSpread name _))
+    = Left $ Core.SelectionField <$> fr name
 selection subs fr  (Full.SelectionInlineFragment fragment)
     | (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment
-    = Right $ Core.SelectionFragment $ Core.Fragment typeCondition $ node selectionSet
-    | otherwise = error "Inline fragments not supported yet"
+        = Right
+        $ Core.SelectionFragment
+        $ Core.Fragment typeCondition
+        $ NonEmpty.fromList
+        $ appendSelection selectionSet
+    | (Full.InlineFragment Nothing _ selectionSet) <- fragment
+        = Left $ appendSelection selectionSet
   where
-    node selections
-        = NonEmpty.fromList
-        $ foldr (appendSelection . selection subs fr) [] selections
-    appendSelection (Left x) acc = x ++ acc
-    appendSelection (Right x) acc = x : acc
+    appendSelection = foldr (either (++) (:) . selection subs fr) []
 
 -- * Fragment replacement
 
@@ -96,14 +97,13 @@ defrag subs (Full.DefinitionFragment fragDef) =
 
 fragmentDefinition :: Schema.Subs -> Full.FragmentDefinition -> Fragmenter
 fragmentDefinition subs (Full.FragmentDefinition name _tc _dirs sels) name'
-    -- TODO: Support fragments within fragments. Fold instead of map.
     | name == name' = selection' <$> do
         selections <- NonEmpty.toList $ selection subs mempty <$> sels
         either id pure selections
     | otherwise = empty
   where
     selection' (Core.SelectionField field') = field'
-    selection' _ = error "Inline fragments not supported yet"
+    selection' _ = error "Fragments within fragments are not supported yet"
 
 field :: Schema.Subs -> Fragmenter -> Full.Field -> Core.Field
 field subs fr (Full.Field a n args _dirs sels) =
diff --git a/stack.yaml b/stack.yaml
index 527dc48..44526e2 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,4 +1,4 @@
-resolver: lts-14.7
+resolver: lts-14.8
 
 packages:
 - .
diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs
index 189306d..337db7e 100644
--- a/tests/Test/FragmentSpec.hs
+++ b/tests/Test/FragmentSpec.hs
@@ -59,3 +59,25 @@ spec = describe "Inline fragment executor" $ do
                     ]
                 ]
          in actual `shouldBe` expected
+
+    it "embeds inline fragments without type" $ do
+        let query = [r|{
+          garment {
+            circumference
+            ... {
+              size
+            }
+          }
+        }|]
+            resolvers = Schema.object "garment" $ return [circumference,  size]
+
+        actual <- graphql (resolvers :| []) query
+        let expected = object
+                [ "data" .= object
+                    [ "garment" .= object
+                        [ "circumference" .= (60 :: Int)
+                        , "size" .= ("L" :: Text)
+                        ]
+                    ]
+                ]
+         in actual `shouldBe` expected