blob: 3aa31b076dd339d03fa62dde7bc8354f1284192f (
plain)
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
|
{-# 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.
module Language.GraphQL.AST.Transform
( document
) where
import Control.Applicative (empty)
import Data.Bifunctor (first)
import Data.Either (partitionEithers)
import Data.Foldable (fold, foldMap)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Monoid (Alt(Alt,getAlt), (<>))
import qualified Language.GraphQL.AST as Full
import qualified Language.GraphQL.AST.Core as Core
import qualified Language.GraphQL.Schema as Schema
-- | Replaces a fragment name by a list of 'Core.Field'. If the name doesn't
-- match an empty list is returned.
type Fragmenter = Core.Name -> [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 fr ops
where
(fr, ops) = first foldFrags
. partitionEithers
. NonEmpty.toList
$ defrag subs
<$> doc
foldFrags :: [Fragmenter] -> Fragmenter
foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs
-- * Operation
-- TODO: Replace Maybe by MonadThrow CustomError
operations
:: Schema.Subs
-> Fragmenter
-> [Full.OperationDefinition]
-> Maybe Core.Document
operations subs fr = NonEmpty.nonEmpty . fmap (operation subs fr)
operation
:: Schema.Subs
-> Fragmenter
-> Full.OperationDefinition
-> Core.Operation
operation subs fr (Full.OperationSelectionSet sels) =
operation subs fr $ Full.OperationDefinition Full.Query empty empty empty sels
-- TODO: Validate Variable definitions with substituter
operation subs fr (Full.OperationDefinition Full.Query name _vars _dirs sels) =
Core.Query name $ appendSelection subs fr sels
operation subs fr (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =
Core.Mutation name $ appendSelection subs fr sels
selection
:: Schema.Subs
-> Fragmenter
-> Full.Selection
-> Either [Core.Selection] Core.Selection
selection subs fr (Full.SelectionField fld)
= Right $ Core.SelectionField $ field subs fr fld
selection _ fr (Full.SelectionFragmentSpread (Full.FragmentSpread name _))
= Left $ Core.SelectionField <$> fr name
selection subs fr (Full.SelectionInlineFragment fragment)
| (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment
= Right
$ Core.SelectionFragment
$ Core.Fragment typeCondition
$ appendSelection subs fr selectionSet
| (Full.InlineFragment Nothing _ selectionSet) <- fragment
= Left $ NonEmpty.toList $ appendSelection subs fr selectionSet
-- * Fragment replacement
-- | Extract Fragments into a single Fragmenter function and a Operation
-- Definition.
defrag
:: Schema.Subs
-> Full.Definition
-> Either Fragmenter Full.OperationDefinition
defrag _ (Full.DefinitionOperation op) =
Right op
defrag subs (Full.DefinitionFragment fragDef) =
Left $ fragmentDefinition subs fragDef
fragmentDefinition :: Schema.Subs -> Full.FragmentDefinition -> Fragmenter
fragmentDefinition subs (Full.FragmentDefinition name _tc _dirs sels) name'
| name == name' = selection' <$> do
selections <- NonEmpty.toList $ selection subs mempty <$> sels
either id pure selections
| otherwise = empty
where
selection' (Core.SelectionField field') = field'
selection' _ = error "Fragments within fragments are not supported yet"
field :: Schema.Subs -> Fragmenter -> Full.Field -> Core.Field
field subs fr (Full.Field a n args _dirs sels) =
Core.Field a n (fold $ argument subs `traverse` args) (foldr go empty sels)
where
go :: Full.Selection -> [Core.Selection] -> [Core.Selection]
go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = ((Core.SelectionField <$> fr name) <>)
go sel = (either id pure (selection subs fr sel) <>)
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
appendSelection ::
Schema.Subs ->
Fragmenter ->
NonEmpty Full.Selection ->
NonEmpty Core.Selection
appendSelection subs fr = NonEmpty.fromList
. foldr (either (++) (:) . selection subs fr) []
|
