diff --git a/src/Language/GraphQL/Executor.hs b/src/Language/GraphQL/Executor.hs index 878dee6..7a46244 100644 --- a/src/Language/GraphQL/Executor.hs +++ b/src/Language/GraphQL/Executor.hs @@ -3,7 +3,6 @@ obtain one at https://mozilla.org/MPL/2.0/. -} {-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} module Language.GraphQL.Executor @@ -15,12 +14,16 @@ module Language.GraphQL.Executor , executeRequest ) where +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Reader (ReaderT(..), ask, runReader) import qualified Language.GraphQL.AST.Document as Full import qualified Data.Aeson as Aeson import Data.Foldable (find) +import Data.Functor.Identity (Identity) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Int (Int32) +import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Text (Text) import qualified Data.Text as Text @@ -32,6 +35,25 @@ import qualified Language.GraphQL.Type.Internal as Type.Internal import Language.GraphQL.Type.Schema (Schema) import qualified Language.GraphQL.Type.Schema as Schema +newtype TransformT m a = TransformT + { runTransformT :: ReaderT Type.Subs m a + } + +instance Functor m => Functor (TransformT m) where + fmap f = TransformT . fmap f . runTransformT + +instance Applicative m => Applicative (TransformT m) where + pure = TransformT . pure + TransformT f <*> TransformT x = TransformT $ f <*> x + +instance Monad m => Monad (TransformT m) where + TransformT x >>= f = TransformT $ x >>= runTransformT . f + +instance MonadTrans TransformT where + lift = TransformT . lift + +type Transform = TransformT Identity + data Segment = Segment String | Index Int data Error = Error @@ -133,44 +155,48 @@ document = foldr filterOperation [] operationDefinition' : accumulator filterOperation _ accumulator = accumulator -- Fragment. -operationDefinition :: Type.Subs -> Full.OperationDefinition -> Operation -operationDefinition coercedVariableValues = \case - Full.OperationDefinition operationType _ _ _ selectionSet' _ -> - Operation operationType coercedVariableValues - $ selectionSet selectionSet' - Full.SelectionSet selectionSet' _ -> - Operation Full.Query coercedVariableValues (selectionSet selectionSet') +transform :: Full.OperationDefinition -> Transform Operation +transform (Full.OperationDefinition operationType _ _ _ selectionSet' _) = do + coercedVariableValues <- TransformT ask + transformedSelections <- selectionSet selectionSet' + pure $ Operation operationType coercedVariableValues transformedSelections +transform (Full.SelectionSet selectionSet' _) = do + coercedVariableValues <- TransformT ask + transformedSelections <- selectionSet selectionSet' + pure $ Operation Full.Query coercedVariableValues transformedSelections -selectionSet :: Full.SelectionSet -> SelectionSet -selectionSet = NonEmpty.toList . fmap selection +selectionSet :: Full.SelectionSet -> Transform SelectionSet +selectionSet = traverse selection . NonEmpty.toList -selection :: Full.Selection -> Selection -selection (Full.FieldSelection field') = FieldSelection $ field field' +selection :: Full.Selection -> Transform Selection +selection (Full.FieldSelection field') = FieldSelection <$> field field' selection (Full.FragmentSpreadSelection fragmentSpread') = - FragmentSpreadSelection $ fragmentSpread fragmentSpread' + FragmentSpreadSelection <$> fragmentSpread fragmentSpread' selection (Full.InlineFragmentSelection inlineFragment') = - InlineFragmentSelection $ inlineFragment inlineFragment' + InlineFragmentSelection <$> inlineFragment inlineFragment' -inlineFragment :: Full.InlineFragment -> InlineFragment -inlineFragment (Full.InlineFragment typeCondition directives selectionSet' location) = - InlineFragment +inlineFragment :: Full.InlineFragment -> Transform InlineFragment +inlineFragment (Full.InlineFragment typeCondition directives selectionSet' location) = do + transformedSelections <- selectionSet selectionSet' + pure $ InlineFragment typeCondition (directive <$> directives) - (selectionSet selectionSet') + transformedSelections location -fragmentSpread :: Full.FragmentSpread -> FragmentSpread +fragmentSpread :: Full.FragmentSpread -> Transform FragmentSpread fragmentSpread (Full.FragmentSpread name' directives location) = - FragmentSpread name' (directive <$> directives) location + pure $ FragmentSpread name' (directive <$> directives) location -field :: Full.Field -> Field -field (Full.Field alias' name' arguments' directives' selectionSet' location') = - Field +field :: Full.Field -> Transform Field +field (Full.Field alias' name' arguments' directives' selectionSet' location') = do + transformedSelections <- traverse selection selectionSet' + pure $ Field alias' name' (argument <$> arguments') (directive <$> directives') - (selection <$> selectionSet') + transformedSelections location' argument :: Full.Argument -> Argument @@ -220,14 +246,17 @@ executeRequest schema sourceDocument operationName variableValues initialValue = subscribe topSelections schema coercedVariables initialValue where schemaTypes = Schema.types schema - transformedDocument = document sourceDocument + operationDefinitions = document sourceDocument operationAndVariables = do - operationDefinition' <- getOperation transformedDocument operationName + operationDefinition <- getOperation operationDefinitions operationName coercedVariableValues <- coerceVariableValues schemaTypes - operationDefinition' + operationDefinition variableValues - pure $ operationDefinition coercedVariableValues operationDefinition' + pure + $ flip runReader coercedVariableValues + $ runTransformT + $ transform operationDefinition getOperation :: [Full.OperationDefinition] -> Maybe String -> Either QueryError Full.OperationDefinition getOperation [operation] Nothing = Right operation @@ -278,7 +307,7 @@ executeSelectionSet selections objectType _objectValue variableValues = let _groupedFieldSet = collectFields objectType selections variableValues in mempty -collectFields :: Out.ObjectType IO -> SelectionSet -> Type.Subs -> OrderedMap [Selection] +collectFields :: Out.ObjectType IO -> SelectionSet -> Type.Subs -> OrderedMap (NonEmpty Selection) collectFields = mempty coerceVariableValues :: Coerce.VariableValue a