Support nested fragments

... without forward lookup.
This commit is contained in:
Eugen Wissner 2019-11-09 23:24:31 +01:00
parent b77da3d492
commit 1dd6b7b013
3 changed files with 45 additions and 24 deletions

View File

@ -17,6 +17,9 @@ All notable changes to this project will be documented in this file.
- (Unsupported) nested fragments doesn't throw a runtime error but return a
transformation error.
### Added
- Nested fragments support without forward lookup.
## [0.5.1.0] - 2019-10-22
### Deprecated
- `Language.GraphQL.AST.Arguments`. Use `[Language.GraphQL.AST.Argument]`

View File

@ -19,7 +19,7 @@ import qualified Language.GraphQL.AST.Core as Core
import qualified Language.GraphQL.Schema as Schema
-- | Associates a fragment name with a list of 'Core.Field's.
type Fragments = HashMap Core.Name (NonEmpty Core.Field)
type Fragments = HashMap Core.Name (NonEmpty Core.Selection)
data Replacement = Replacement
{ substitute :: Schema.Subs
@ -31,11 +31,14 @@ type TransformT a = ReaderT Replacement Maybe a
-- | Rewrites the original syntax tree into an intermediate representation used
-- for query execution.
document :: Schema.Subs -> Full.Document -> Maybe Core.Document
document subs doc =
(runReaderT (operations operations') . Replacement subs) =<< fragments'
document subs doc = do
fragmentMap <- foldr go (Just HashMap.empty) fragments'
runReaderT (operations operations') $ Replacement subs fragmentMap
where
(fragments', operations') = foldr (defrag subs) (Just HashMap.empty, [])
$ NonEmpty.toList doc
(fragments', operations') = foldr defragment ([], []) doc
go fragDef (Just fragmentsMap) =
runReaderT (fragmentDefinition fragDef) (Replacement subs fragmentsMap)
go _ Nothing = Nothing
-- * Operation
@ -60,7 +63,7 @@ selection ::
selection (Full.SelectionField fld) = Right . Core.SelectionField <$> field fld
selection (Full.SelectionFragmentSpread (Full.FragmentSpread name _)) = do
fragments' <- asks fragments
lift $ Left . fmap Core.SelectionField <$> HashMap.lookup name fragments'
lift $ Left <$> HashMap.lookup name fragments'
selection (Full.SelectionInlineFragment fragment)
| (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment
= Right
@ -73,31 +76,24 @@ selection (Full.SelectionInlineFragment fragment)
-- * Fragment replacement
-- | Extract fragments into a single 'HashMap' and operation definitions.
defrag ::
Schema.Subs ->
defragment ::
Full.Definition ->
(Maybe Fragments, [Full.OperationDefinition]) ->
(Maybe Fragments, [Full.OperationDefinition])
defrag _ (Full.DefinitionOperation op) (fragments', operations') =
([Full.FragmentDefinition], [Full.OperationDefinition]) ->
([Full.FragmentDefinition], [Full.OperationDefinition])
defragment (Full.DefinitionOperation op) (fragments', operations') =
(fragments', op : operations')
defrag subs (Full.DefinitionFragment fragDef) (Just fragments', operations') =
(runReaderT (fragmentDefinition fragDef) (Replacement subs fragments'), operations')
defrag _ _ (Nothing, operations') =
(Nothing, operations')
defragment (Full.DefinitionFragment fragDef) (fragments', operations') =
(fragDef : fragments', operations')
fragmentDefinition :: Full.FragmentDefinition -> TransformT Fragments
fragmentDefinition (Full.FragmentDefinition name _tc _dirs sels) = do
emitted <- emitValue
newValue <- lift $ traverse extractField emitted
newValue <- emitValue
fragments' <- asks fragments
lift . Just $ HashMap.insert name newValue fragments'
where
emitValue = do
selections <- traverse selection sels
pure $ selections >>= either id pure
extractField :: Core.Selection -> Maybe Core.Field
extractField (Core.SelectionField field') = Just field'
extractField _ = Nothing -- Fragments within fragments are not supported yet
field :: Full.Field -> TransformT Core.Field
field (Full.Field a n args _dirs sels) = do

View File

@ -91,7 +91,29 @@ spec = describe "Inline fragment executor" $ do
}|]
actual <- graphql (size :| []) query
actual `shouldNotSatisfy` hasErrors
where
hasErrors (Object object') = HashMap.member "errors" object'
let hasErrors (Object object') = HashMap.member "errors" object'
hasErrors _ = True
in actual `shouldNotSatisfy` hasErrors
it "evaluates nested fragments" $ do
let query = [r|
{
...hatFragment
}
fragment hatFragment on Hat {
...circumferenceFragment
}
fragment circumferenceFragment on Hat {
circumference
}
|]
actual <- graphql (circumference :| []) query
let expected = object
[ "data" .= object
[ "circumference" .= (60 :: Int)
]
]
in actual `shouldBe` expected