From 4c0d226030015c98ce76ebb4815dc9162ad10b11 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Sat, 7 Dec 2019 09:46:00 +0100 Subject: Move Transform to Language.GraphQL.Execute Language.GraphQL.AST.Transform is an internal module. Even though it works with the AST, it is a part of the execution process, it translates the original parser tree into a simpler one, so the executor has less work to do. Language.GraphQL.AST should contain only the parser and be independent from other packages, so it can be used on its own. --- src/Language/GraphQL/Execute/Transform.hs | 184 ++++++++++++++++++++++++++++++ 1 file changed, 184 insertions(+) create mode 100644 src/Language/GraphQL/Execute/Transform.hs (limited to 'src/Language/GraphQL/Execute') diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs new file mode 100644 index 0000000..9bcb3b2 --- /dev/null +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE TupleSections #-} + +-- | After the document is parsed, before getting executed the AST is +-- transformed into a similar, simpler AST. This module is responsible for +-- this transformation. +module Language.GraphQL.Execute.Transform + ( document + ) where + +import Control.Arrow (first) +import Control.Monad (foldM, unless) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) +import Control.Monad.Trans.State (StateT, evalStateT, gets, modify) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List.NonEmpty as NonEmpty +import Data.Sequence (Seq, (<|), (><)) +import qualified Language.GraphQL.AST as Full +import qualified Language.GraphQL.AST.Core as Core +import qualified Language.GraphQL.Execute.Directive as Directive +import qualified Language.GraphQL.Schema as Schema + +-- | Associates a fragment name with a list of 'Core.Field's. +data Replacement = Replacement + { fragments :: HashMap Core.Name Core.Fragment + , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition + } + +type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a + +liftJust :: forall a. a -> TransformT a +liftJust = lift . lift . Just + +-- | Rewrites the original syntax tree into an intermediate representation used +-- for query execution. +document :: Schema.Subs -> Full.Document -> Maybe Core.Document +document subs document' = + flip runReaderT subs + $ evalStateT (collectFragments >> operations operationDefinitions) + $ Replacement HashMap.empty fragmentTable + where + (fragmentTable, operationDefinitions) = foldr defragment mempty document' + defragment (Full.DefinitionOperation definition) acc = + (definition :) <$> acc + defragment (Full.DefinitionFragment definition) acc = + let (Full.FragmentDefinition name _ _ _) = definition + in first (HashMap.insert name definition) acc + +-- * Operation + +operations :: [Full.OperationDefinition] -> TransformT Core.Document +operations operations' = do + coreOperations <- traverse operation operations' + lift . lift $ NonEmpty.nonEmpty coreOperations + +operation :: Full.OperationDefinition -> TransformT Core.Operation +operation (Full.OperationSelectionSet sels) = + operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels +-- TODO: Validate Variable definitions with substituter +operation (Full.OperationDefinition Full.Query name _vars _dirs sels) = + Core.Query name <$> appendSelection sels +operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels) = + Core.Mutation name <$> appendSelection sels + +-- * Selection + +selection :: + Full.Selection -> + TransformT (Either (Seq Core.Selection) Core.Selection) +selection (Full.SelectionField field') = + maybe (Left mempty) (Right . Core.SelectionField) <$> field field' +selection (Full.SelectionFragmentSpread fragment) = + maybe (Left mempty) (Right . Core.SelectionFragment) + <$> fragmentSpread fragment +selection (Full.SelectionInlineFragment fragment) = + inlineFragment fragment + +appendSelection :: + Traversable t => + t Full.Selection -> + TransformT (Seq Core.Selection) +appendSelection = foldM go mempty + where + go acc sel = append acc <$> selection sel + append acc (Left list) = list >< acc + append acc (Right one) = one <| acc + +directives :: [Full.Directive] -> TransformT [Core.Directive] +directives = traverse directive + where + directive (Full.Directive directiveName directiveArguments) = + Core.Directive directiveName <$> arguments directiveArguments + +-- * Fragment replacement + +-- | Extract fragment definitions into a single 'HashMap'. +collectFragments :: TransformT () +collectFragments = do + fragDefs <- gets fragmentDefinitions + let nextValue = head $ HashMap.elems fragDefs + unless (HashMap.null fragDefs) $ do + _ <- fragmentDefinition nextValue + collectFragments + +inlineFragment :: + Full.InlineFragment -> + TransformT (Either (Seq Core.Selection) Core.Selection) +inlineFragment (Full.InlineFragment type' directives' selectionSet) = do + fragmentDirectives <- Directive.selection <$> directives directives' + case fragmentDirectives of + Nothing -> pure $ Left mempty + _ -> do + fragmentSelectionSet <- appendSelection selectionSet + pure $ maybe Left selectionFragment type' fragmentSelectionSet + where + selectionFragment typeName = Right + . Core.SelectionFragment + . Core.Fragment typeName + +fragmentSpread :: Full.FragmentSpread -> TransformT (Maybe Core.Fragment) +fragmentSpread (Full.FragmentSpread name directives') = do + spreadDirectives <- Directive.selection <$> directives directives' + fragments' <- gets fragments + fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments') + pure $ fragment <$ spreadDirectives + where + lookupDefinition = do + fragmentDefinitions' <- gets fragmentDefinitions + found <- lift . lift $ HashMap.lookup name fragmentDefinitions' + fragmentDefinition found + +fragmentDefinition :: + Full.FragmentDefinition -> + TransformT Core.Fragment +fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do + modify deleteFragmentDefinition + fragmentSelection <- appendSelection selections + let newValue = Core.Fragment type' fragmentSelection + modify $ insertFragment newValue + liftJust newValue + where + deleteFragmentDefinition (Replacement fragments' fragmentDefinitions') = + Replacement fragments' $ HashMap.delete name fragmentDefinitions' + insertFragment newValue (Replacement fragments' fragmentDefinitions') = + let newFragments = HashMap.insert name newValue fragments' + in Replacement newFragments fragmentDefinitions' + +field :: Full.Field -> TransformT (Maybe Core.Field) +field (Full.Field alias name arguments' directives' selections) = do + fieldArguments <- traverse argument arguments' + fieldSelections <- appendSelection selections + fieldDirectives <- Directive.selection <$> directives directives' + let field' = Core.Field alias name fieldArguments fieldSelections + pure $ field' <$ fieldDirectives + +arguments :: [Full.Argument] -> TransformT Core.Arguments +arguments = fmap Core.Arguments . foldM go HashMap.empty + where + go arguments' argument' = do + (Core.Argument name value') <- argument argument' + return $ HashMap.insert name value' arguments' + +argument :: Full.Argument -> TransformT Core.Argument +argument (Full.Argument n v) = Core.Argument n <$> value v + +value :: Full.Value -> TransformT Core.Value +value (Full.Variable n) = do + substitute' <- lift ask + lift . lift $ substitute' n +value (Full.Int i) = pure $ Core.Int i +value (Full.Float f) = pure $ Core.Float f +value (Full.String x) = pure $ Core.String x +value (Full.Boolean b) = pure $ Core.Boolean b +value Full.Null = pure Core.Null +value (Full.Enum e) = pure $ Core.Enum e +value (Full.List l) = + Core.List <$> traverse value l +value (Full.Object o) = + Core.Object . HashMap.fromList <$> traverse objectField o + +objectField :: Full.ObjectField -> TransformT (Core.Name, Core.Value) +objectField (Full.ObjectField name value') = (name,) <$> value value' -- cgit v1.2.3