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.
This commit is contained in:
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user