Support inline fragments on types

src/Language/GraphQL/AST.hs

@@ -35,6 +35,7 @@ import Data.List.NonEmpty (NonEmpty)
 import Data.Text (Text)
 import Language.GraphQL.AST.Core ( Alias
                                  , Name
+                                 , TypeCondition
                                  )
 
 -- * Document
@@ -113,9 +114,6 @@ data FragmentDefinition
 {-# DEPRECATED FragmentName "Use Name instead" #-}
 type FragmentName = Name
 
--- | Type condition.
-type TypeCondition = Name
-
 -- * Input values
 
 -- | Input value.

src/Language/GraphQL/AST/Core.hs

@@ -4,16 +4,18 @@ module Language.GraphQL.AST.Core
     , Argument(..)
     , Document
     , Field(..)
+    , Fragment(..)
     , Name
     , ObjectField(..)
     , Operation(..)
+    , Selection(..)
+    , TypeCondition
     , Value(..)
     ) where
 
 import Data.Int (Int32)
 import Data.List.NonEmpty (NonEmpty)
 import Data.String
-
 import Data.Text (Text)
 
 -- | Name
@@ -26,8 +28,8 @@ type Document = NonEmpty Operation
 --
 -- Currently only queries and mutations are supported.
 data Operation
-    = Query (Maybe Text) (NonEmpty Field)
-    | Mutation (Maybe Text) (NonEmpty Field)
+    = Query (Maybe Text) (NonEmpty Selection)
+    | Mutation (Maybe Text) (NonEmpty Selection)
     deriving (Eq, Show)
 
 -- | A single GraphQL field.
@@ -51,7 +53,7 @@ data Operation
 -- * "zuck" is an alias for "user". "id" and "name" have no aliases.
 -- * "id: 4" is an argument for "name". "id" and "name don't have any
 -- arguments.
-data Field = Field (Maybe Alias) Name [Argument] [Field] deriving (Eq, Show)
+data Field = Field (Maybe Alias) Name [Argument] [Selection] deriving (Eq, Show)
 
 -- | Alternative field name.
 --
@@ -100,3 +102,17 @@ instance IsString Value where
 --
 -- A list of 'ObjectField's represents a GraphQL object type.
 data ObjectField = ObjectField Name Value deriving (Eq, Show)
+
+-- | Type condition.
+type TypeCondition = Name
+
+-- | Represents fragments and inline fragments.
+data Fragment
+    = Fragment TypeCondition (NonEmpty Selection)
+    deriving (Eq, Show)
+
+-- | Single selection element.
+data Selection
+    = SelectionFragment Fragment
+    | SelectionField Field
+    deriving (Eq, Show)

src/Language/GraphQL/AST/Transform.hs

@@ -65,13 +65,21 @@ selection
   :: Schema.Subs
   -> Fragmenter
   -> Full.Selection
-  -> Either [Core.Field] Core.Field
+  -> Either [Core.Selection] Core.Selection
 selection subs fr (Full.SelectionField fld) =
-  Right $ field subs fr fld
+  Right $ Core.SelectionField $ field subs fr fld
 selection _    fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) =
-  Left $ fr n
-selection _ _  (Full.SelectionInlineFragment _)  =
-  error "Inline fragments not supported yet"
+  Left $ Core.SelectionField <$> fr n
+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"
+  where
+    node selections
+        = NonEmpty.fromList
+        $ foldr (appendSelection . selection subs fr) [] selections
+    appendSelection (Left x) acc = x ++ acc
+    appendSelection (Right x) acc = x : acc
 
 -- * Fragment replacement
 
@@ -87,18 +95,22 @@ defrag subs (Full.DefinitionFragment fragDef) =
   Left $ fragmentDefinition subs fragDef
 
 fragmentDefinition :: Schema.Subs -> Full.FragmentDefinition -> Fragmenter
-fragmentDefinition subs (Full.FragmentDefinition name _tc _dirs sels) name' =
+fragmentDefinition subs (Full.FragmentDefinition name _tc _dirs sels) name'
     -- TODO: Support fragments within fragments. Fold instead of map.
-  if name == name'
-  then either id pure =<< NonEmpty.toList (selection subs mempty <$> sels)
-  else empty
+    | 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"
 
 field :: Schema.Subs -> Fragmenter -> Full.Field -> Core.Field
 field subs fr (Full.Field a n args _dirs sels) =
     Core.Field a n (fold $ argument subs `traverse` args) (foldr go empty sels)
   where
-    go :: Full.Selection -> [Core.Field] -> [Core.Field]
-    go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = (fr name <>)
+    go :: Full.Selection -> [Core.Selection] -> [Core.Selection]
+    go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = ((Core.SelectionField <$> fr name) <>)
     go sel = (either id pure (selection subs fr sel) <>)
 
 argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument

src/Language/GraphQL/Schema.hs

@@ -153,11 +153,21 @@ withField v fld
 --   'Resolver' to each 'Field'. Resolves into a value containing the
 --   resolved 'Field', or a null value and error information.
 resolve :: MonadIO m
-    => [Resolver m] -> [Field] -> CollectErrsT m Aeson.Value
+    => [Resolver m] -> [Selection] -> CollectErrsT m Aeson.Value
 resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
   where
-    tryResolvers fld = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers fld) resolvers
-    compareResolvers (Field _ name _ _) (Resolver name' _) = name == name'
+    resolveTypeName (Resolver "__typename" f) = do
+        value <- f $ Field Nothing "__typename" mempty mempty
+        return $ HashMap.lookupDefault "" "__typename" value
+    resolveTypeName _ = return ""
+    tryResolvers (SelectionField fld@(Field _ name _ _))
+        = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers name) resolvers
+    tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do
+        that <-  maybe (return "") resolveTypeName (find (compareResolvers "__typename") resolvers)
+        if Aeson.String typeCondition == that
+            then fmap fold . traverse tryResolvers $ selections'
+            else return mempty
+    compareResolvers name (Resolver name' _) = name == name'
     tryResolver fld (Resolver _ resolver)  = resolver fld
     errmsg fld@(Field _ name _ _) = do
         addErrMsg $ T.unwords ["field", name, "not resolved."]

tests/Test/FragmentSpec.hs

@@ -9,7 +9,7 @@ import Data.List.NonEmpty (NonEmpty(..))
 import Data.Text (Text)
 import Language.GraphQL
 import qualified Language.GraphQL.Schema as Schema
-import Test.Hspec (Spec, it, shouldBe, xdescribe)
+import Test.Hspec (Spec, describe, it, shouldBe)
 import Text.RawString.QQ (r)
 
 size :: Schema.Resolver IO
@@ -37,21 +37,25 @@ inlineQuery = [r|{
 }|]
 
 spec :: Spec
-spec = xdescribe "Inline fragment executor" $ do
+spec = describe "Inline fragment executor" $ do
     it "chooses the first selection if the type matches" $ do
         actual <- graphql (garment "Hat" :| []) inlineQuery
         let expected = object
+                [ "data" .= object
                     [ "garment" .= object
                         [ "circumference" .= (60 :: Int)
                         ]
                     ]
+                ]
          in actual `shouldBe` expected
 
     it "chooses the last selection if the type matches" $ do
         actual <- graphql (garment "Shirt" :| []) inlineQuery
         let expected = object
+                [ "data" .= object
                     [ "garment" .= object
                         [ "size" .= ("L" :: Text)
                         ]
                     ]
+                ]
          in actual `shouldBe` expected