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

View File

@ -4,16 +4,18 @@ module Language.GraphQL.AST.Core
, Argument(..) , Argument(..)
, Document , Document
, Field(..) , Field(..)
, Fragment(..)
, Name , Name
, ObjectField(..) , ObjectField(..)
, Operation(..) , Operation(..)
, Selection(..)
, TypeCondition
, Value(..) , Value(..)
) where ) where
import Data.Int (Int32) import Data.Int (Int32)
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import Data.String import Data.String
import Data.Text (Text) import Data.Text (Text)
-- | Name -- | Name
@ -26,8 +28,8 @@ type Document = NonEmpty Operation
-- --
-- Currently only queries and mutations are supported. -- Currently only queries and mutations are supported.
data Operation data Operation
= Query (Maybe Text) (NonEmpty Field) = Query (Maybe Text) (NonEmpty Selection)
| Mutation (Maybe Text) (NonEmpty Field) | Mutation (Maybe Text) (NonEmpty Selection)
deriving (Eq, Show) deriving (Eq, Show)
-- | A single GraphQL field. -- | A single GraphQL field.
@ -51,7 +53,7 @@ data Operation
-- * "zuck" is an alias for "user". "id" and "name" have no aliases. -- * "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 -- * "id: 4" is an argument for "name". "id" and "name don't have any
-- arguments. -- 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. -- | Alternative field name.
-- --
@ -100,3 +102,17 @@ instance IsString Value where
-- --
-- A list of 'ObjectField's represents a GraphQL object type. -- A list of 'ObjectField's represents a GraphQL object type.
data ObjectField = ObjectField Name Value deriving (Eq, Show) 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 :: Schema.Subs
-> Fragmenter -> Fragmenter
-> Full.Selection -> Full.Selection
-> Either [Core.Field] Core.Field -> Either [Core.Selection] Core.Selection
selection subs fr (Full.SelectionField fld) = 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)) = selection _ fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) =
Left $ fr n Left $ Core.SelectionField <$> fr n
selection _ _ (Full.SelectionInlineFragment _) = selection subs fr (Full.SelectionInlineFragment fragment)
error "Inline fragments not supported yet" | (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 -- * Fragment replacement
@ -87,18 +95,22 @@ defrag subs (Full.DefinitionFragment fragDef) =
Left $ fragmentDefinition subs fragDef Left $ fragmentDefinition subs fragDef
fragmentDefinition :: Schema.Subs -> Full.FragmentDefinition -> Fragmenter 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. -- TODO: Support fragments within fragments. Fold instead of map.
if name == name' | name == name' = selection' <$> do
then either id pure =<< NonEmpty.toList (selection subs mempty <$> sels) selections <- NonEmpty.toList $ selection subs mempty <$> sels
else empty 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 :: Schema.Subs -> Fragmenter -> Full.Field -> Core.Field
field subs fr (Full.Field a n args _dirs sels) = field subs fr (Full.Field a n args _dirs sels) =
Core.Field a n (fold $ argument subs `traverse` args) (foldr go empty sels) Core.Field a n (fold $ argument subs `traverse` args) (foldr go empty sels)
where where
go :: Full.Selection -> [Core.Field] -> [Core.Field] go :: Full.Selection -> [Core.Selection] -> [Core.Selection]
go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = (fr name <>) go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = ((Core.SelectionField <$> fr name) <>)
go sel = (either id pure (selection subs fr sel) <>) go sel = (either id pure (selection subs fr sel) <>)
argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument 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 -- 'Resolver' to each 'Field'. Resolves into a value containing the
-- resolved 'Field', or a null value and error information. -- resolved 'Field', or a null value and error information.
resolve :: MonadIO m 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 resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
where where
tryResolvers fld = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers fld) resolvers resolveTypeName (Resolver "__typename" f) = do
compareResolvers (Field _ name _ _) (Resolver name' _) = name == name' 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 tryResolver fld (Resolver _ resolver) = resolver fld
errmsg fld@(Field _ name _ _) = do errmsg fld@(Field _ name _ _) = do
addErrMsg $ T.unwords ["field", name, "not resolved."] addErrMsg $ T.unwords ["field", name, "not resolved."]

View File

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