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 Data.Bifunctor (first)
import Data.Foldable (find)
import Data.Functor ((<&>))
import Data.Functor.Identity (Identity)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.Int (Int32)
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (catMaybes)
import Data.Maybe (fromMaybe, isJust)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Language.GraphQL.Execute.Coerce as Coerce
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 as Type
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
data Replacement = Replacement
{ variableValues :: Type.Subs
, fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
, visitedFragments :: HashSet Full.Name
, types :: HashMap Full.Name (Type IO)
}
newtype TransformT m a = TransformT
@ -144,7 +147,7 @@ data Field = Field
Full.Location
data Fragment = Fragment
(Maybe Full.TypeCondition) SelectionSet Full.Location
(Type.Internal.CompositeType IO) SelectionSet Full.Location
data Value
= Variable Full.Name
@ -186,24 +189,50 @@ transform (Full.SelectionSet selectionSet' _) = do
pure $ Operation Full.Query coercedVariableValues transformedSelections
selectionSet :: Full.SelectionSet -> Transform SelectionSet
selectionSet = fmap catMaybes . traverse selection . NonEmpty.toList
selectionSet = selectionSetOpt . NonEmpty.toList
selection :: Full.Selection -> Transform (Maybe Selection)
selection (Full.FieldSelection field') = fmap FieldSelection <$> field field'
selectionSetOpt :: Full.SelectionSetOpt -> Transform SelectionSet
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') =
fmap FragmentSelection <$> fragmentSpread fragmentSpread'
maybeToSelectionSet FragmentSelection $ fragmentSpread fragmentSpread'
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 = fmap Type.selection . traverse directive
inlineFragment :: Full.InlineFragment -> Transform (Maybe Fragment)
inlineFragment (Full.InlineFragment typeCondition directives' selectionSet' location) = do
inlineFragment :: Full.InlineFragment
-> Transform (Either SelectionSet Fragment)
inlineFragment (Full.InlineFragment maybeCondition directives' selectionSet' location)
| Just typeCondition <- maybeCondition = do
transformedSelections <- selectionSet selectionSet'
transformedDirectives <- directives directives'
pure $ transformedDirectives
>> pure (Fragment typeCondition transformedSelections location)
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 spreadName directives' location) = do
@ -216,24 +245,25 @@ fragmentSpread (Full.FragmentSpread spreadName directives' location) = do
Just (Full.FragmentDefinition _ typeCondition _ selections _)
| visitedFragment -> pure Nothing
| otherwise -> do
fragmentType <- asks
$ Type.Internal.lookupTypeCondition typeCondition
. types
traverse (traverseSelections selections) fragmentType
Nothing -> pure Nothing
where
traverseSelections selections typeCondition = do
transformedSelections <- TransformT
$ local fragmentInserter
$ runTransformT
$ selectionSet selections
pure $ Just $ Fragment
(Just typeCondition)
transformedSelections
location
Nothing ->
pure Nothing
where
pure $ Fragment typeCondition transformedSelections location
fragmentInserter replacement@Replacement{ visitedFragments } = replacement
{ visitedFragments = HashSet.insert spreadName visitedFragments }
field :: Full.Field -> Transform (Maybe Field)
field (Full.Field alias' name' arguments' directives' selectionSet' location') = do
transformedSelections <- catMaybes <$> traverse selection selectionSet'
transformedSelections <- selectionSetOpt selectionSet'
transformedDirectives <- directives directives'
let transformedField = Field
alias'
@ -329,6 +359,7 @@ executeRequest schema sourceDocument operationName variableValues initialValue =
{ variableValues = coercedVariableValues
, fragmentDefinitions = fragmentDefinitions'
, visitedFragments = mempty
, types = schemaTypes
}
pure
$ flip runReader replacement
@ -380,12 +411,26 @@ executeSelectionSet
-> Aeson.Object
-> Type.Subs
-> Aeson.Object
executeSelectionSet selections objectType _objectValue variableValues =
let _groupedFieldSet = collectFields objectType selections variableValues
executeSelectionSet selections objectType _objectValue _variableValues =
let _groupedFieldSet = collectFields objectType selections
in mempty
collectFields :: Out.ObjectType IO -> SelectionSet -> Type.Subs -> OrderedMap (NonEmpty Selection)
collectFields = mempty
collectFields :: Out.ObjectType IO
-> 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
=> forall m