Support inline fragments on types

This commit is contained in:
Eugen Wissner 2019-10-07 21:03:07 +02:00
parent b2a9ec7d82
commit 856efc5d25
5 changed files with 69 additions and 29 deletions

View File

@ -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.

View File

@ -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)

View File

@ -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

View File

@ -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."]

View File

@ -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