From 856efc5d256449d9282f6547bb5f677d0a7fe482 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Mon, 7 Oct 2019 21:03:07 +0200 Subject: [PATCH] Support inline fragments on types --- src/Language/GraphQL/AST.hs | 4 +-- src/Language/GraphQL/AST/Core.hs | 24 ++++++++++++++--- src/Language/GraphQL/AST/Transform.hs | 38 ++++++++++++++++++--------- src/Language/GraphQL/Schema.hs | 16 ++++++++--- tests/Test/FragmentSpec.hs | 16 ++++++----- 5 files changed, 69 insertions(+), 29 deletions(-) diff --git a/src/Language/GraphQL/AST.hs b/src/Language/GraphQL/AST.hs index dc7f6ac..6794ae3 100644 --- a/src/Language/GraphQL/AST.hs +++ b/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. diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs index 977153f..a2a53be 100644 --- a/src/Language/GraphQL/AST/Core.hs +++ b/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) diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/AST/Transform.hs index 9ecaaac..4b82082 100644 --- a/src/Language/GraphQL/AST/Transform.hs +++ b/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,19 +95,23 @@ defrag subs (Full.DefinitionFragment fragDef) = Left $ fragmentDefinition subs 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. - if name == name' - then either id pure =<< NonEmpty.toList (selection subs mempty <$> sels) - else empty +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" 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 sel = (either id pure (selection subs fr sel) <>) + 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 argument subs (Full.Argument n v) = Core.Argument n <$> value subs v diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs index 99de5a9..112847f 100644 --- a/src/Language/GraphQL/Schema.hs +++ b/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."] diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index 219be4a..189306d 100644 --- a/tests/Test/FragmentSpec.hs +++ b/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,12 +37,14 @@ 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 - [ "garment" .= object - [ "circumference" .= (60 :: Int) + [ "data" .= object + [ "garment" .= object + [ "circumference" .= (60 :: Int) + ] ] ] in actual `shouldBe` expected @@ -50,8 +52,10 @@ spec = xdescribe "Inline fragment executor" $ do it "chooses the last selection if the type matches" $ do actual <- graphql (garment "Shirt" :| []) inlineQuery let expected = object - [ "garment" .= object - [ "size" .= ("L" :: Text) + [ "data" .= object + [ "garment" .= object + [ "size" .= ("L" :: Text) + ] ] ] in actual `shouldBe` expected