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
|
{-# LANGUAGE CPP #-}
module Data.GraphQL.Schema
( Schema(..)
, QueryRoot
, ResolverO
, ResolverM
, Output(..)
, Subs
, Scalar(..)
, withField
, withFieldFinal
, withFields
, withArgument
, outputTraverse
, fields
-- * Reexports
, Field
, Argument
) where
#if !MIN_VERSION_base(4,8,0)
import Data.Traversable (traverse)
#endif
import Control.Applicative
import Data.Maybe (catMaybes)
import Data.Foldable (fold)
import Data.String (IsString(fromString))
import Data.Aeson (ToJSON(toJSON))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text, pack)
import qualified Data.Text as T (null)
import Data.GraphQL.AST
data Schema f = Schema (QueryRoot f)
type QueryRoot f = ResolverM f
-- TODO: Come up with a unique data type or better renaming
type ResolverM f = Field -> f (HashMap Text Output)
type ResolverO f = [Field] -> f Output
data Output = OutputObject (HashMap Text Output)
| OutputList [Output]
| OutputScalar Scalar
| OutputEnum Text
deriving (Show)
type Subs = Text -> Maybe Text
-- TODO: GraphQL spec for Integer Scalar is 32bits
data Scalar = ScalarInt Int
| ScalarFloat Double
| ScalarString Text
| ScalarBoolean Bool
| ScalarID Text
deriving (Show)
instance IsString Scalar where
fromString = ScalarString . pack
instance ToJSON Scalar where
toJSON (ScalarInt x) = toJSON x
toJSON (ScalarFloat x) = toJSON x
toJSON (ScalarString x) = toJSON x
toJSON (ScalarBoolean x) = toJSON x
toJSON (ScalarID x) = toJSON x
instance ToJSON Output where
toJSON (OutputObject x) = toJSON $ toJSON <$> x
toJSON (OutputList x) = toJSON $ toJSON <$> x
toJSON (OutputScalar x) = toJSON x
toJSON (OutputEnum x) = toJSON x
-- * Helpers
withField :: Alternative f => Text -> ([Argument] -> ResolverO f) -> ResolverM f
withField n f (Field alias name' args _ sels) =
if n == name'
then HashMap.singleton aliasOrName <$> f args (fields sels)
else empty
where
aliasOrName = if T.null alias then name' else alias
withFieldFinal :: Alternative f => Text -> Output -> ResolverM f
withFieldFinal n o fld@(Field _ _ [] _ []) = withField n (\_ _ -> pure o) fld
withFieldFinal _ _ _ = empty
withFields :: Alternative f => ResolverM f -> ResolverO f
withFields f = fmap (OutputObject . fold) . traverse f
outputTraverse :: Applicative f => (a -> f Output) -> [a] -> f Output
outputTraverse f = fmap OutputList . traverse f
withArgument :: Text -> [Argument] -> Maybe Scalar
withArgument x [Argument n s] = if x == n then scalarValue s else Nothing
withArgument _ _ = Nothing
scalarValue :: Value -> Maybe Scalar
scalarValue (ValueInt x) = Just . ScalarInt $ fromIntegral x
scalarValue (ValueString (StringValue x)) = Just $ ScalarString x
scalarValue _ = Nothing
fields :: SelectionSet -> [Field]
fields = catMaybes . fmap field
field :: Selection -> Maybe Field
field (SelectionField x) = Just x
field _ = Nothing
|
