graphql/src/Language/GraphQL/AST/Transform.hs

153 lines
5.9 KiB
Haskell
Raw Normal View History

-- | After the document is parsed, before getting executed the AST is
-- transformed into a similar, simpler AST. This module is responsible for
-- this transformation.
2019-07-14 05:58:05 +02:00
module Language.GraphQL.AST.Transform
( document
) where
import Data.Foldable (fold)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
2019-10-19 10:00:25 +02:00
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
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 (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 =
case fragments of
Just fragments' -> operations subs fragments' operations'
Nothing -> Nothing
where
(fragments, operations') = foldr (defrag subs) (Just HashMap.empty, [])
$ NonEmpty.toList doc
-- * Operation
2017-02-25 20:46:51 +01:00
-- TODO: Replace Maybe by MonadThrow CustomError
operations ::
Schema.Subs ->
Fragments ->
[Full.OperationDefinition] ->
Maybe Core.Document
operations subs fragments operations' = do
coreOperations <- traverse (operation subs fragments) operations'
NonEmpty.nonEmpty coreOperations
operation ::
Schema.Subs ->
Fragments ->
Full.OperationDefinition ->
Maybe Core.Operation
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) =
Core.Query name <$> appendSelection subs fragments sels
operation subs fragments (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =
Core.Mutation name <$> appendSelection subs fragments sels
selection ::
Schema.Subs ->
Fragments ->
Full.Selection ->
Maybe (Either (NonEmpty Core.Selection) Core.Selection)
selection subs fragments (Full.SelectionField fld)
= Right . Core.SelectionField <$> field subs fragments fld
selection _ fragments (Full.SelectionFragmentSpread (Full.FragmentSpread name _))
= Left . fmap Core.SelectionField <$> HashMap.lookup name fragments
selection subs fragments (Full.SelectionInlineFragment fragment)
2019-10-07 21:03:07 +02:00
| (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment
= Right
. Core.SelectionFragment
. Core.Fragment typeCondition
<$> appendSelection subs fragments selectionSet
| (Full.InlineFragment Nothing _ selectionSet) <- fragment
= Left <$> appendSelection subs fragments selectionSet
-- * Fragment replacement
-- | Extract fragments into a single 'HashMap' and operation definitions.
defrag ::
Schema.Subs ->
Full.Definition ->
(Maybe Fragments, [Full.OperationDefinition]) ->
(Maybe Fragments, [Full.OperationDefinition])
defrag _ (Full.DefinitionOperation op) (fragments, operations') =
(fragments, op : 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 ->
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 <- 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 -> Maybe Core.Field
field subs fragments (Full.Field a n args _dirs sels) =
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
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
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
2019-10-19 10:00:25 +02:00
appendSelection ::
Schema.Subs ->
Fragments ->
2019-10-19 10:00:25 +02:00
NonEmpty Full.Selection ->
Maybe (NonEmpty Core.Selection)
appendSelection subs fragments fullSelection = do
coreSelection <-appendSelectionOpt subs fragments fullSelection
NonEmpty.nonEmpty coreSelection