1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
|
{-# LANGUAGE TupleSections #-}
-- | After the document is parsed, before getting executed the AST is
-- transformed into a similar, simpler AST. This module is responsible for
-- this transformation.
module Language.GraphQL.AST.Transform
( document
) where
import Control.Monad (foldM)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
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 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)
data Replacement = Replacement
{ substitute :: Schema.Subs
, fragments :: Fragments
}
type TransformT a = ReaderT Replacement 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 =
(runReaderT (operations operations') . Replacement subs) =<< fragments'
where
(fragments', operations') = foldr (defrag subs) (Just HashMap.empty, [])
$ NonEmpty.toList doc
-- * Operation
-- TODO: Replace Maybe by MonadThrow CustomError
operations :: [Full.OperationDefinition] -> TransformT Core.Document
operations operations' = do
coreOperations <- traverse operation operations'
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 (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 (NonEmpty Core.Selection) Core.Selection)
selection (Full.SelectionField fld) = Right . Core.SelectionField <$> field fld
selection (Full.SelectionFragmentSpread (Full.FragmentSpread name _)) = do
fragments' <- asks fragments
lift $ Left . fmap Core.SelectionField <$> HashMap.lookup name fragments'
selection (Full.SelectionInlineFragment fragment)
| (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment
= Right
. Core.SelectionFragment
. Core.Fragment typeCondition
<$> appendSelection selectionSet
| (Full.InlineFragment Nothing _ selectionSet) <- fragment
= Left <$> appendSelection 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') =
(runReaderT (fragmentDefinition fragDef) (Replacement subs fragments'), operations')
defrag _ _ (Nothing, operations') =
(Nothing, operations')
fragmentDefinition :: Full.FragmentDefinition -> TransformT Fragments
fragmentDefinition (Full.FragmentDefinition name _tc _dirs sels) = do
emitted <- emitValue
newValue <- lift $ traverse extractField emitted
fragments' <- asks fragments
lift . Just $ HashMap.insert name newValue fragments'
where
emitValue = do
selections <- traverse selection 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 :: Full.Field -> TransformT Core.Field
field (Full.Field a n args _dirs sels) = do
arguments <- traverse argument args
selection' <- appendSelectionOpt 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' <- asks substitute
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
appendSelectionOpt ::
Traversable t =>
t Full.Selection ->
TransformT [Core.Selection]
appendSelectionOpt = foldM go []
where
go acc sel = append acc <$> selection sel
append acc (Left list) = NonEmpty.toList list <> acc
append acc (Right one) = one : acc
appendSelection ::
NonEmpty Full.Selection ->
TransformT (NonEmpty Core.Selection)
appendSelection fullSelection = do
coreSelection <-appendSelectionOpt fullSelection
lift $ NonEmpty.nonEmpty coreSelection
|
