OSS/graphql
1
1
Fork 1
Code Issues 5 Pull Requests Actions Releases 22 Wiki Activity

Propagate Maybe in the transform tree

Browse Source 
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.
This commit is contained in:
Eugen Wissner 2019-11-01 14:24:21 +01:00
parent 0e3b6184be
commit 417ff5da7d
1 changed files with 52 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

91
src/Language/GraphQL/AST/Transform.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
-- | After the document is parsed, before getting executed the AST is -- | After the document is parsed, before getting executed the AST is
-- transformed into a similar, simpler AST. This module is responsible for -- transformed into a similar, simpler AST. This module is responsible for
-- this transformation. -- this transformation.
@ -12,26 +10,24 @@ import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (fromMaybe)
import qualified Language.GraphQL.AST as Full import qualified Language.GraphQL.AST as Full
import qualified Language.GraphQL.AST.Core as Core import qualified Language.GraphQL.AST.Core as Core
import qualified Language.GraphQL.Schema as Schema import qualified Language.GraphQL.Schema as Schema
-- | Associates a fragment name with a list of 'Core.Field's. -- | 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 -- | Rewrites the original syntax tree into an intermediate representation used
-- for query execution. -- for query execution.
document :: Schema.Subs -> Full.Document -> Maybe Core.Document 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 where
(fragments, operations') = foldr (defrag subs) mempty (fragments, operations') = foldr (defrag subs) (Just HashMap.empty, [])
$ NonEmpty.toList doc $ NonEmpty.toList doc
extractFragment :: Fragments -> Core.Name -> [Core.Selection]
extractFragment fragments name = Core.SelectionField
<$> fromMaybe mempty (HashMap.lookup name fragments)
-- * Operation -- * Operation
-- TODO: Replace Maybe by MonadThrow CustomError -- 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 operation subs fragments $ Full.OperationDefinition Full.Query mempty mempty mempty sels
-- TODO: Validate Variable definitions with substituter -- TODO: Validate Variable definitions with substituter
operation subs fragments (Full.OperationDefinition Full.Query name _vars _dirs sels) = 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) = 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 :: selection ::
Schema.Subs -> Schema.Subs ->
Fragments -> Fragments ->
Full.Selection -> Full.Selection ->
Either [Core.Selection] Core.Selection Maybe (Either (NonEmpty Core.Selection) Core.Selection)
selection subs fragments (Full.SelectionField fld) 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 _)) 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) selection subs fragments (Full.SelectionInlineFragment fragment)
| (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment | (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment
= Right = Right
$ Core.SelectionFragment . Core.SelectionFragment
$ Core.Fragment typeCondition . Core.Fragment typeCondition
$ appendSelection subs fragments selectionSet <$> appendSelection subs fragments selectionSet
| (Full.InlineFragment Nothing _ selectionSet) <- fragment | (Full.InlineFragment Nothing _ selectionSet) <- fragment
= Left $ NonEmpty.toList $ appendSelection subs fragments selectionSet = Left <$> appendSelection subs fragments selectionSet
-- * Fragment replacement -- * Fragment replacement
@ -81,35 +77,37 @@ selection subs fragments (Full.SelectionInlineFragment fragment)
defrag :: defrag ::
Schema.Subs -> Schema.Subs ->
Full.Definition -> Full.Definition ->
(Fragments, [Full.OperationDefinition]) -> (Maybe Fragments, [Full.OperationDefinition]) ->
(Fragments, [Full.OperationDefinition]) (Maybe Fragments, [Full.OperationDefinition])
defrag _ (Full.DefinitionOperation op) (fragments, operations') = defrag _ (Full.DefinitionOperation op) (fragments, operations') =
(fragments, op : operations') (fragments, op : operations')
defrag subs (Full.DefinitionFragment fragDef) (fragments, operations') = defrag subs (Full.DefinitionFragment fragDef) (Just fragments, operations') =
(fragmentDefinition subs fragments fragDef, operations') (fragmentDefinition subs fragments fragDef, operations')
defrag _ _ (Nothing, operations') =
(Nothing, operations')
fragmentDefinition :: fragmentDefinition ::
Schema.Subs -> Schema.Subs ->
Fragments -> Fragments ->
Full.FragmentDefinition -> Full.FragmentDefinition ->
Fragments Maybe Fragments
fragmentDefinition subs fragments (Full.FragmentDefinition name _tc _dirs sels) = fragmentDefinition subs fragments (Full.FragmentDefinition name _tc _dirs sels) = do
HashMap.insert name (extractField <$> emitValue) fragments emitted <- emitValue
newValue <- traverse extractField emitted
Just $ HashMap.insert name newValue fragments
where where
emitValue :: Maybe (NonEmpty Core.Selection)
emitValue = do emitValue = do
selections <- NonEmpty.toList $ selection subs mempty <$> sels selections <- traverse (selection subs fragments) sels
either id pure selections pure $ selections >>= either id pure
extractField (Core.SelectionField field') = field' extractField :: Core.Selection -> Maybe Core.Field
extractField _ = error "Fragments within fragments are not supported yet" 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) = field subs fragments (Full.Field a n args _dirs sels) =
Core.Field a n (fold $ argument subs `traverse` args) (foldr go mempty sels) Core.Field a n (fold $ argument subs `traverse` args)
where <$> appendSelectionOpt subs fragments sels
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) <>)
argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument
argument subs (Full.Argument n v) = Core.Argument n <$> value subs v 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 :: Schema.Subs -> Full.ObjectField -> Maybe Core.ObjectField
objectField subs (Full.ObjectField n v) = Core.ObjectField n <$> value subs v 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 :: appendSelection ::
Schema.Subs -> Schema.Subs ->
Fragments -> Fragments ->
NonEmpty Full.Selection -> NonEmpty Full.Selection ->
NonEmpty Core.Selection Maybe (NonEmpty Core.Selection)
appendSelection subs fragments = NonEmpty.fromList appendSelection subs fragments fullSelection = do
. foldr (either (++) (:) . selection subs fragments) [] coreSelection <-appendSelectionOpt subs fragments fullSelection
NonEmpty.nonEmpty coreSelection