diff options
Diffstat (limited to 'src/Language/GraphQL/AST/Transform.hs')
| -rw-r--r-- | src/Language/GraphQL/AST/Transform.hs | 220 |
1 files changed, 117 insertions, 103 deletions
diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/AST/Transform.hs index 3aa31b0..95cdfbb 100644 --- a/src/Language/GraphQL/AST/Transform.hs +++ b/src/Language/GraphQL/AST/Transform.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ExplicitForAll #-} -- | After the document is parsed, before getting executed the AST is -- transformed into a similar, simpler AST. This module is responsible for @@ -7,130 +8,143 @@ module Language.GraphQL.AST.Transform ( document ) where -import Control.Applicative (empty) -import Data.Bifunctor (first) -import Data.Either (partitionEithers) -import Data.Foldable (fold, foldMap) -import Data.List.NonEmpty (NonEmpty) +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.Monoid (Alt(Alt,getAlt), (<>)) +import Data.Sequence (Seq, (<|), (><)) import qualified Language.GraphQL.AST as Full import qualified Language.GraphQL.AST.Core as Core import qualified Language.GraphQL.Schema as Schema --- | Replaces a fragment name by a list of 'Core.Field'. If the name doesn't --- match an empty list is returned. -type Fragmenter = Core.Name -> [Core.Field] +-- | Associates a fragment name with a list of 'Core.Field's. +data Replacement = Replacement + { fragments :: HashMap Core.Name (Seq Core.Selection) + , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition + } + +type TransformT a = StateT Replacement (ReaderT Schema.Subs 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 = operations subs fr ops +document subs document' = + flip runReaderT subs + $ evalStateT (collectFragments >> operations operationDefinitions) + $ Replacement HashMap.empty fragmentTable where - (fr, ops) = first foldFrags - . partitionEithers - . NonEmpty.toList - $ defrag subs - <$> doc - - foldFrags :: [Fragmenter] -> Fragmenter - foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs + (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 -- TODO: Replace Maybe by MonadThrow CustomError -operations - :: Schema.Subs - -> Fragmenter - -> [Full.OperationDefinition] - -> Maybe Core.Document -operations subs fr = NonEmpty.nonEmpty . fmap (operation subs fr) - -operation - :: Schema.Subs - -> Fragmenter - -> Full.OperationDefinition - -> Core.Operation -operation subs fr (Full.OperationSelectionSet sels) = - operation subs fr $ Full.OperationDefinition Full.Query empty empty empty sels +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 subs fr (Full.OperationDefinition Full.Query name _vars _dirs sels) = - Core.Query name $ appendSelection subs fr sels -operation subs fr (Full.OperationDefinition Full.Mutation name _vars _dirs sels) = - Core.Mutation name $ appendSelection subs fr sels - -selection - :: Schema.Subs - -> Fragmenter - -> Full.Selection - -> Either [Core.Selection] Core.Selection -selection subs fr (Full.SelectionField fld) - = Right $ Core.SelectionField $ field subs fr fld -selection _ fr (Full.SelectionFragmentSpread (Full.FragmentSpread name _)) - = Left $ Core.SelectionField <$> fr name -selection subs fr (Full.SelectionInlineFragment fragment) +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 :: + Full.Selection -> + TransformT (Either (Seq Core.Selection) Core.Selection) +selection (Full.SelectionField fld) = Right . Core.SelectionField <$> field fld +selection (Full.SelectionFragmentSpread (Full.FragmentSpread name _)) = do + fragments' <- gets fragments + Left <$> maybe lookupDefinition liftJust (HashMap.lookup name fragments') + where + lookupDefinition :: TransformT (Seq Core.Selection) + lookupDefinition = do + fragmentDefinitions' <- gets fragmentDefinitions + found <- lift . lift $ HashMap.lookup name fragmentDefinitions' + fragmentDefinition found +selection (Full.SelectionInlineFragment fragment) | (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment = Right - $ Core.SelectionFragment - $ Core.Fragment typeCondition - $ appendSelection subs fr selectionSet + . Core.SelectionFragment + . Core.Fragment typeCondition + <$> appendSelection selectionSet | (Full.InlineFragment Nothing _ selectionSet) <- fragment - = Left $ NonEmpty.toList $ appendSelection subs fr selectionSet + = Left <$> appendSelection selectionSet -- * Fragment replacement --- | Extract Fragments into a single Fragmenter function and a Operation --- Definition. -defrag - :: Schema.Subs - -> Full.Definition - -> Either Fragmenter Full.OperationDefinition -defrag _ (Full.DefinitionOperation op) = - Right op -defrag subs (Full.DefinitionFragment fragDef) = - Left $ fragmentDefinition subs fragDef - -fragmentDefinition :: Schema.Subs -> Full.FragmentDefinition -> Fragmenter -fragmentDefinition subs (Full.FragmentDefinition name _tc _dirs sels) name' - | name == name' = selection' <$> do - selections <- NonEmpty.toList $ selection subs mempty <$> sels - either id pure selections - | otherwise = empty +-- | 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 + +fragmentDefinition :: + Full.FragmentDefinition -> + TransformT (Seq Core.Selection) +fragmentDefinition (Full.FragmentDefinition name _tc _dirs selections) = do + modify deleteFragmentDefinition + newValue <- appendSelection selections + modify $ insertFragment newValue + liftJust newValue where - selection' (Core.SelectionField field') = field' - selection' _ = error "Fragments within fragments are not supported yet" + 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 Core.Field +field (Full.Field a n args _dirs sels) = do + arguments <- traverse argument args + selection' <- appendSelection sels + return $ Core.Field a n arguments selection' + +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 n v) = (n,) <$> value v -field :: Schema.Subs -> Fragmenter -> Full.Field -> Core.Field -field subs fr (Full.Field a n args _dirs sels) = - Core.Field a n (fold $ argument subs `traverse` args) (foldr go empty sels) +appendSelection :: + Traversable t => + t Full.Selection -> + TransformT (Seq Core.Selection) +appendSelection = foldM go mempty where - go :: Full.Selection -> [Core.Selection] -> [Core.Selection] - go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = ((Core.SelectionField <$> fr name) <>) - go sel = (either id pure (selection subs fr sel) <>) - -argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument -argument subs (Full.Argument n v) = Core.Argument n <$> value subs v - -value :: Schema.Subs -> Full.Value -> Maybe Core.Value -value subs (Full.ValueVariable n) = subs n -value _ (Full.ValueInt i) = pure $ Core.ValueInt i -value _ (Full.ValueFloat f) = pure $ Core.ValueFloat f -value _ (Full.ValueString x) = pure $ Core.ValueString x -value _ (Full.ValueBoolean b) = pure $ Core.ValueBoolean b -value _ Full.ValueNull = pure Core.ValueNull -value _ (Full.ValueEnum e) = pure $ Core.ValueEnum e -value subs (Full.ValueList l) = - Core.ValueList <$> traverse (value subs) l -value subs (Full.ValueObject o) = - Core.ValueObject <$> traverse (objectField subs) o - -objectField :: Schema.Subs -> Full.ObjectField -> Maybe Core.ObjectField -objectField subs (Full.ObjectField n v) = Core.ObjectField n <$> value subs v + go acc sel = append acc <$> selection sel + append acc (Left list) = list >< acc + append acc (Right one) = one <| acc -appendSelection :: - Schema.Subs -> - Fragmenter -> - NonEmpty Full.Selection -> - NonEmpty Core.Selection -appendSelection subs fr = NonEmpty.fromList - . foldr (either (++) (:) . selection subs fr) [] +liftJust :: forall a. a -> TransformT a +liftJust = lift . lift . Just |