Collect fields

This commit is contained in:
Eugen Wissner 2021-08-26 08:44:39 +02:00
parent db721a3f53
commit 5505739e21

View File

@ -24,29 +24,32 @@ import qualified Language.GraphQL.AST.Document as Full
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import Data.Bifunctor (first) import Data.Bifunctor (first)
import Data.Foldable (find) import Data.Foldable (find)
import Data.Functor ((<&>))
import Data.Functor.Identity (Identity) import Data.Functor.Identity (Identity)
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.HashSet (HashSet) import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet import qualified Data.HashSet as HashSet
import Data.Int (Int32) import Data.Int (Int32)
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (catMaybes) import Data.Maybe (fromMaybe, isJust)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Language.GraphQL.Execute.Coerce as Coerce import qualified Language.GraphQL.Execute.Coerce as Coerce
import Language.GraphQL.Execute.OrderedMap (OrderedMap) import Language.GraphQL.Execute.OrderedMap (OrderedMap)
import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
import qualified Language.GraphQL.Type as Type import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.Internal as Type.Internal import qualified Language.GraphQL.Type.Internal as Type.Internal
import Language.GraphQL.Type.Schema (Schema) import Language.GraphQL.Type.Schema (Schema, Type)
import qualified Language.GraphQL.Type.Schema as Schema import qualified Language.GraphQL.Type.Schema as Schema
data Replacement = Replacement data Replacement = Replacement
{ variableValues :: Type.Subs { variableValues :: Type.Subs
, fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
, visitedFragments :: HashSet Full.Name , visitedFragments :: HashSet Full.Name
, types :: HashMap Full.Name (Type IO)
} }
newtype TransformT m a = TransformT newtype TransformT m a = TransformT
@ -144,7 +147,7 @@ data Field = Field
Full.Location Full.Location
data Fragment = Fragment data Fragment = Fragment
(Maybe Full.TypeCondition) SelectionSet Full.Location (Type.Internal.CompositeType IO) SelectionSet Full.Location
data Value data Value
= Variable Full.Name = Variable Full.Name
@ -186,24 +189,50 @@ transform (Full.SelectionSet selectionSet' _) = do
pure $ Operation Full.Query coercedVariableValues transformedSelections pure $ Operation Full.Query coercedVariableValues transformedSelections
selectionSet :: Full.SelectionSet -> Transform SelectionSet selectionSet :: Full.SelectionSet -> Transform SelectionSet
selectionSet = fmap catMaybes . traverse selection . NonEmpty.toList selectionSet = selectionSetOpt . NonEmpty.toList
selection :: Full.Selection -> Transform (Maybe Selection) selectionSetOpt :: Full.SelectionSetOpt -> Transform SelectionSet
selection (Full.FieldSelection field') = fmap FieldSelection <$> field field' selectionSetOpt = foldM go []
where
go accumulatedSelections currentSelection =
selection currentSelection <&> (accumulatedSelections ++)
selection :: Full.Selection -> Transform SelectionSet
selection (Full.FieldSelection field') =
maybeToSelectionSet FieldSelection $ field field'
selection (Full.FragmentSpreadSelection fragmentSpread') = selection (Full.FragmentSpreadSelection fragmentSpread') =
fmap FragmentSelection <$> fragmentSpread fragmentSpread' maybeToSelectionSet FragmentSelection $ fragmentSpread fragmentSpread'
selection (Full.InlineFragmentSelection inlineFragment') = selection (Full.InlineFragmentSelection inlineFragment') =
fmap FragmentSelection <$> inlineFragment inlineFragment' either id (pure . FragmentSelection) <$> inlineFragment inlineFragment'
maybeToSelectionSet :: forall a
. (a -> Selection)
-> Transform (Maybe a)
-> Transform SelectionSet
maybeToSelectionSet selectionType = fmap (maybe [] $ pure . selectionType)
directives :: [Full.Directive] -> Transform (Maybe [Type.Directive]) directives :: [Full.Directive] -> Transform (Maybe [Type.Directive])
directives = fmap Type.selection . traverse directive directives = fmap Type.selection . traverse directive
inlineFragment :: Full.InlineFragment -> Transform (Maybe Fragment) inlineFragment :: Full.InlineFragment
inlineFragment (Full.InlineFragment typeCondition directives' selectionSet' location) = do -> Transform (Either SelectionSet Fragment)
transformedSelections <- selectionSet selectionSet' inlineFragment (Full.InlineFragment maybeCondition directives' selectionSet' location)
transformedDirectives <- directives directives' | Just typeCondition <- maybeCondition = do
pure $ transformedDirectives transformedSelections <- selectionSet selectionSet'
>> pure (Fragment typeCondition transformedSelections location) transformedDirectives <- directives directives'
maybeFragmentType <- asks
$ Type.Internal.lookupTypeCondition typeCondition
. types
pure $ case transformedDirectives >> maybeFragmentType of
Just fragmentType -> Right
$ Fragment fragmentType transformedSelections location
Nothing -> Left []
| otherwise = do
transformedSelections <- selectionSet selectionSet'
transformedDirectives <- directives directives'
pure $ if isJust transformedDirectives
then Left transformedSelections
else Left []
fragmentSpread :: Full.FragmentSpread -> Transform (Maybe Fragment) fragmentSpread :: Full.FragmentSpread -> Transform (Maybe Fragment)
fragmentSpread (Full.FragmentSpread spreadName directives' location) = do fragmentSpread (Full.FragmentSpread spreadName directives' location) = do
@ -216,24 +245,25 @@ fragmentSpread (Full.FragmentSpread spreadName directives' location) = do
Just (Full.FragmentDefinition _ typeCondition _ selections _) Just (Full.FragmentDefinition _ typeCondition _ selections _)
| visitedFragment -> pure Nothing | visitedFragment -> pure Nothing
| otherwise -> do | otherwise -> do
transformedSelections <- TransformT fragmentType <- asks
$ local fragmentInserter $ Type.Internal.lookupTypeCondition typeCondition
$ runTransformT . types
$ selectionSet selections traverse (traverseSelections selections) fragmentType
pure $ Just $ Fragment Nothing -> pure Nothing
(Just typeCondition)
transformedSelections
location
Nothing ->
pure Nothing
where where
traverseSelections selections typeCondition = do
transformedSelections <- TransformT
$ local fragmentInserter
$ runTransformT
$ selectionSet selections
pure $ Fragment typeCondition transformedSelections location
fragmentInserter replacement@Replacement{ visitedFragments } = replacement fragmentInserter replacement@Replacement{ visitedFragments } = replacement
{ visitedFragments = HashSet.insert spreadName visitedFragments } { visitedFragments = HashSet.insert spreadName visitedFragments }
field :: Full.Field -> Transform (Maybe Field) field :: Full.Field -> Transform (Maybe Field)
field (Full.Field alias' name' arguments' directives' selectionSet' location') = do field (Full.Field alias' name' arguments' directives' selectionSet' location') = do
transformedSelections <- catMaybes <$> traverse selection selectionSet' transformedSelections <- selectionSetOpt selectionSet'
transformedDirectives <- directives directives' transformedDirectives <- directives directives'
let transformedField = Field let transformedField = Field
alias' alias'
@ -329,6 +359,7 @@ executeRequest schema sourceDocument operationName variableValues initialValue =
{ variableValues = coercedVariableValues { variableValues = coercedVariableValues
, fragmentDefinitions = fragmentDefinitions' , fragmentDefinitions = fragmentDefinitions'
, visitedFragments = mempty , visitedFragments = mempty
, types = schemaTypes
} }
pure pure
$ flip runReader replacement $ flip runReader replacement
@ -380,12 +411,26 @@ executeSelectionSet
-> Aeson.Object -> Aeson.Object
-> Type.Subs -> Type.Subs
-> Aeson.Object -> Aeson.Object
executeSelectionSet selections objectType _objectValue variableValues = executeSelectionSet selections objectType _objectValue _variableValues =
let _groupedFieldSet = collectFields objectType selections variableValues let _groupedFieldSet = collectFields objectType selections
in mempty in mempty
collectFields :: Out.ObjectType IO -> SelectionSet -> Type.Subs -> OrderedMap (NonEmpty Selection) collectFields :: Out.ObjectType IO
collectFields = mempty -> SelectionSet
-> OrderedMap (NonEmpty Field)
collectFields objectType = foldl forEach OrderedMap.empty
where
forEach groupedFields (FieldSelection fieldSelection) =
let Field maybeAlias fieldName _ _ _ = fieldSelection
responseKey = fromMaybe fieldName maybeAlias
in OrderedMap.insert responseKey (fieldSelection :| []) groupedFields
forEach groupedFields (FragmentSelection selectionFragment)
| Fragment fragmentType fragmentSelectionSet _ <- selectionFragment
, Type.Internal.doesFragmentTypeApply fragmentType objectType =
let fragmentGroupedFieldSet =
collectFields objectType fragmentSelectionSet
in groupedFields <> fragmentGroupedFieldSet
| otherwise = groupedFields
coerceVariableValues :: Coerce.VariableValue a coerceVariableValues :: Coerce.VariableValue a
=> forall m => forall m