blob: 3dac75741400f3f6c68f67d1dc063fb87707a045 (
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
|
module Data.GraphQL.AST.Transform where
import Control.Applicative (empty)
import Control.Monad ((<=<))
import Data.Bifunctor (first)
import Data.Either (partitionEithers)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (maybeToList)
import Data.Monoid (Alt(Alt,getAlt))
import Data.Foldable (foldMap)
import Data.Text (Text)
import qualified Data.GraphQL.AST as Full
import qualified Data.GraphQL.AST.Core as Core
import qualified Data.GraphQL.Schema as Schema
type Name = Text
-- | Replaces a fragment name by a list of 'Field'. If the name doesn't match an
-- empty list is returned.
type Fragmenter = Name -> [Core.Field]
-- TODO: Replace Maybe by Either CustomError
document :: Schema.Subs -> Full.Document -> Maybe Core.Document
document subs defs = operations subs fr ops
where
(fr, ops) = first foldFrags . partitionEithers . NonEmpty.toList $ defrag <$> defs
foldFrags :: [Fragmenter] -> Fragmenter
foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs
-- * Operation
operations
:: Schema.Subs
-> Fragmenter
-> [Full.OperationDefinition]
-> Maybe Core.Document
operations subs fr = NonEmpty.nonEmpty <=< traverse (operation subs fr)
operation
:: Schema.Subs
-> Fragmenter
-> Full.OperationDefinition
-> Maybe Core.Operation
operation subs fr (Full.OperationSelectionSet sels) =
operation subs fr $ Full.OperationDefinition Full.Query empty empty empty sels
operation _subs fr (Full.OperationDefinition ot _n _vars _dirs sels) =
case ot of
Full.Query -> Core.Query <$> node
Full.Mutation -> Core.Mutation <$> node
where
node = traverse (hush <=< selection fr) sels
selection :: Fragmenter -> Full.Selection -> Maybe (Either [Core.Field] Core.Field)
selection fr (Full.SelectionField _fld) = Right <$> field fr _fld
selection fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) = Just . Left $ fr n
selection _ (Full.SelectionInlineFragment _) = error "Inline fragments not supported yet"
-- * Fragment replacement
-- | Extract Fragments into a single Fragmenter function and a Operation
-- Definition.
defrag :: Full.Definition -> Either Fragmenter Full.OperationDefinition
defrag (Full.DefinitionOperation op) = Right op
defrag (Full.DefinitionFragment fragDef) = Left $ fragmentDefinition fragDef
fragmentDefinition :: Full.FragmentDefinition -> Fragmenter
fragmentDefinition (Full.FragmentDefinition name _tc _dirs sels) name' =
-- TODO: Support fragments within fragments. Fold instead of map.
if name == name'
then either id pure =<< maybeToList =<< NonEmpty.toList (selection mempty <$> sels)
else empty
field :: Fragmenter -> Full.Field -> Maybe Core.Field
field fr (Full.Field a n args _ sels) =
Core.Field a n (argument <$> args) <$> traverse (hush <=< selection fr) sels
argument :: Full.Argument -> Core.Argument
argument (Full.Argument n v) = Core.Argument n (value v)
value :: Full.Value -> Core.Value
value (Full.ValueVariable _) = error "Variables within fragments not supported yet"
value (Full.ValueInt i) = Core.ValueInt i
value (Full.ValueFloat f) = Core.ValueFloat f
value (Full.ValueString x) = Core.ValueString x
value (Full.ValueBoolean b) = Core.ValueBoolean b
value Full.ValueNull = Core.ValueNull
value (Full.ValueEnum e) = Core.ValueEnum e
value (Full.ValueList l) = Core.ValueList (value <$> l)
value (Full.ValueObject o) = Core.ValueObject (objectField <$> o)
objectField :: Full.ObjectField -> Core.ObjectField
objectField (Full.ObjectField n v) = Core.ObjectField n (value v)
hush :: Either a b -> Maybe b
hush = either (const Nothing) Just
|
