From 417ff5da7d0db6c8e73a238c17368192a3515a93 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Fri, 1 Nov 2019 14:24:21 +0100 Subject: [PATCH] Propagate Maybe in the transform tree Since the transform tree can already find some errors, it may fail here and there. Almost all functions return a Maybe to signalize an error. Will be replaced with an Either of course. --- src/Language/GraphQL/AST/Transform.hs | 91 +++++++++++++++------------ 1 file changed, 52 insertions(+), 39 deletions(-) diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/AST/Transform.hs index 60b4f9c..107e1c6 100644 --- a/src/Language/GraphQL/AST/Transform.hs +++ b/src/Language/GraphQL/AST/Transform.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - -- | After the document is parsed, before getting executed the AST is -- transformed into a similar, simpler AST. This module is responsible for -- this transformation. @@ -12,26 +10,24 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe (fromMaybe) import qualified Language.GraphQL.AST as Full import qualified Language.GraphQL.AST.Core as Core import qualified Language.GraphQL.Schema as Schema -- | Associates a fragment name with a list of 'Core.Field's. -type Fragments = HashMap Core.Name [Core.Field] +type Fragments = HashMap Core.Name (NonEmpty Core.Field) -- | 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 fragments operations' +document subs doc = + case fragments of + Just fragments' -> operations subs fragments' operations' + Nothing -> Nothing where - (fragments, operations') = foldr (defrag subs) mempty + (fragments, operations') = foldr (defrag subs) (Just HashMap.empty, []) $ NonEmpty.toList doc -extractFragment :: Fragments -> Core.Name -> [Core.Selection] -extractFragment fragments name = Core.SelectionField - <$> fromMaybe mempty (HashMap.lookup name fragments) - -- * Operation -- TODO: Replace Maybe by MonadThrow CustomError @@ -53,27 +49,27 @@ operation subs fragments (Full.OperationSelectionSet sels) = operation subs fragments $ Full.OperationDefinition Full.Query mempty mempty mempty sels -- TODO: Validate Variable definitions with substituter operation subs fragments (Full.OperationDefinition Full.Query name _vars _dirs sels) = - pure $ Core.Query name $ appendSelection subs fragments sels + Core.Query name <$> appendSelection subs fragments sels operation subs fragments (Full.OperationDefinition Full.Mutation name _vars _dirs sels) = - pure $ Core.Mutation name $ appendSelection subs fragments sels + Core.Mutation name <$> appendSelection subs fragments sels selection :: Schema.Subs -> Fragments -> Full.Selection -> - Either [Core.Selection] Core.Selection + Maybe (Either (NonEmpty Core.Selection) Core.Selection) selection subs fragments (Full.SelectionField fld) - = Right $ Core.SelectionField $ field subs fragments fld + = Right . Core.SelectionField <$> field subs fragments fld selection _ fragments (Full.SelectionFragmentSpread (Full.FragmentSpread name _)) - = Left $ extractFragment fragments name + = Left . fmap Core.SelectionField <$> HashMap.lookup name fragments selection subs fragments (Full.SelectionInlineFragment fragment) | (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment = Right - $ Core.SelectionFragment - $ Core.Fragment typeCondition - $ appendSelection subs fragments selectionSet + . Core.SelectionFragment + . Core.Fragment typeCondition + <$> appendSelection subs fragments selectionSet | (Full.InlineFragment Nothing _ selectionSet) <- fragment - = Left $ NonEmpty.toList $ appendSelection subs fragments selectionSet + = Left <$> appendSelection subs fragments selectionSet -- * Fragment replacement @@ -81,35 +77,37 @@ selection subs fragments (Full.SelectionInlineFragment fragment) defrag :: Schema.Subs -> Full.Definition -> - (Fragments, [Full.OperationDefinition]) -> - (Fragments, [Full.OperationDefinition]) + (Maybe Fragments, [Full.OperationDefinition]) -> + (Maybe Fragments, [Full.OperationDefinition]) defrag _ (Full.DefinitionOperation op) (fragments, operations') = (fragments, op : operations') -defrag subs (Full.DefinitionFragment fragDef) (fragments, operations') = +defrag subs (Full.DefinitionFragment fragDef) (Just fragments, operations') = (fragmentDefinition subs fragments fragDef, operations') +defrag _ _ (Nothing, operations') = + (Nothing, operations') fragmentDefinition :: Schema.Subs -> Fragments -> Full.FragmentDefinition -> - Fragments -fragmentDefinition subs fragments (Full.FragmentDefinition name _tc _dirs sels) = - HashMap.insert name (extractField <$> emitValue) fragments + Maybe Fragments +fragmentDefinition subs fragments (Full.FragmentDefinition name _tc _dirs sels) = do + emitted <- emitValue + newValue <- traverse extractField emitted + Just $ HashMap.insert name newValue fragments where + emitValue :: Maybe (NonEmpty Core.Selection) emitValue = do - selections <- NonEmpty.toList $ selection subs mempty <$> sels - either id pure selections - extractField (Core.SelectionField field') = field' - extractField _ = error "Fragments within fragments are not supported yet" + selections <- traverse (selection subs fragments) sels + pure $ selections >>= either id pure + extractField :: Core.Selection -> Maybe Core.Field + extractField (Core.SelectionField field') = Just field' + extractField _ = Nothing -- Fragments within fragments are not supported yet -field :: Schema.Subs -> Fragments -> Full.Field -> Core.Field +field :: Schema.Subs -> Fragments -> Full.Field -> Maybe Core.Field field subs fragments (Full.Field a n args _dirs sels) = - Core.Field a n (fold $ argument subs `traverse` args) (foldr go mempty sels) - where - go :: Full.Selection -> [Core.Selection] -> [Core.Selection] - go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = - (extractFragment fragments name <>) - go sel = (either id pure (selection subs fragments sel) <>) + Core.Field a n (fold $ argument subs `traverse` args) + <$> appendSelectionOpt subs fragments sels argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument argument subs (Full.Argument n v) = Core.Argument n <$> value subs v @@ -130,10 +128,25 @@ value subs (Full.ValueObject o) = objectField :: Schema.Subs -> Full.ObjectField -> Maybe Core.ObjectField objectField subs (Full.ObjectField n v) = Core.ObjectField n <$> value subs v +appendSelectionOpt :: + Traversable t => + Schema.Subs -> + Fragments -> + t Full.Selection -> + Maybe [Core.Selection] +appendSelectionOpt subs fragments = foldr go (Just []) + where + go :: Full.Selection -> Maybe [Core.Selection] -> Maybe [Core.Selection] + go _ Nothing = Nothing + go sel (Just acc) = append acc <$> selection subs fragments sel + append acc (Left list) = NonEmpty.toList list <> acc + append acc (Right one) = one : acc + appendSelection :: Schema.Subs -> Fragments -> NonEmpty Full.Selection -> - NonEmpty Core.Selection -appendSelection subs fragments = NonEmpty.fromList - . foldr (either (++) (:) . selection subs fragments) [] + Maybe (NonEmpty Core.Selection) +appendSelection subs fragments fullSelection = do + coreSelection <-appendSelectionOpt subs fragments fullSelection + NonEmpty.nonEmpty coreSelection