/
Schema.hs
319 lines (261 loc) · 12.1 KB
/
Schema.hs
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
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
{-# OPTIONS_HADDOCK not-home #-}
-- | Description: Fully realized GraphQL schema type system at the Haskell value level
--
-- Differs from "Data.GraphQL.AST" in the
-- [graphql](http://hackage.haskell.org/package/graphql) package in that there
-- are no type references. Instead, everything is inlined.
--
-- Equivalent representation of GraphQL /values/ is in "GraphQL.Value".
module GraphQL.Internal.Schema
( GType(..)
-- * Builtin types
, Builtin(..)
-- * Defining new types
, TypeDefinition(..)
, Name
, ArgumentDefinition(..)
, EnumValueDefinition(..)
, EnumTypeDefinition(..)
, FieldDefinition(..)
, Interfaces
, InterfaceTypeDefinition(..)
, ObjectTypeDefinition(..)
, UnionTypeDefinition(..)
-- ** Input types
, InputType(..)
, InputTypeDefinition(..)
, InputObjectTypeDefinition(..)
, InputObjectFieldDefinition(..)
-- * Using existing types
, AnnotatedType(..)
, ListType(..)
, NonNullType(..)
, DefinesTypes(..)
, doesFragmentTypeApply
, getInputTypeDefinition
-- * The schema
, Schema
, makeSchema
, emptySchema
, lookupType
) where
import Protolude
import qualified Data.Map as Map
import GraphQL.Value (Value)
import GraphQL.Internal.Name (HasName(..), Name)
-- | An entire GraphQL schema.
--
-- This is very much a work in progress. Currently, the only thing we provide
-- is a dictionary mapping type names to their definitions.
newtype Schema = Schema (Map Name TypeDefinition) deriving (Eq, Ord, Show)
-- | Create a schema from the root object.
--
-- This is technically an insufficient API, since not all types in a schema
-- need to be reachable from a single root object. However, it's a start.
makeSchema :: ObjectTypeDefinition -> Schema
makeSchema = Schema . getDefinedTypes
emptySchema :: Schema
emptySchema = Schema (Map.empty :: (Map Name TypeDefinition))
-- | Find the type with the given name in the schema.
lookupType :: Schema -> Name -> Maybe TypeDefinition
lookupType (Schema schema) name = Map.lookup name schema
-- | A thing that defines types. Excludes definitions of input types.
class DefinesTypes t where
-- | Get the types defined by @t@
--
-- TODO: This ignores whether a value can define multiple types with the
-- same name, and further admits the possibility that the name embedded in
-- the type definition does not match the name in the returned dictionary.
-- jml would like to have a schema validation phase that eliminates one or
-- both of these possibilities.
--
-- Also pretty much works because we've inlined all our type definitions.
getDefinedTypes :: t -> Map Name TypeDefinition
data AnnotatedType t = TypeNamed t
| TypeList (ListType t)
| TypeNonNull (NonNullType t)
deriving (Eq, Ord, Show)
-- | Get the type that is being annotated.
getAnnotatedType :: AnnotatedType t -> t
getAnnotatedType (TypeNamed t) = t
getAnnotatedType (TypeList (ListType t)) = getAnnotatedType t
getAnnotatedType (TypeNonNull (NonNullTypeNamed t)) = t
getAnnotatedType (TypeNonNull (NonNullTypeList (ListType t))) = getAnnotatedType t
instance HasName t => HasName (AnnotatedType t) where
getName = getName . getAnnotatedType
newtype ListType t = ListType (AnnotatedType t) deriving (Eq, Ord, Show)
data NonNullType t = NonNullTypeNamed t
| NonNullTypeList (ListType t)
deriving (Eq, Ord, Show)
data GType = DefinedType TypeDefinition | BuiltinType Builtin deriving (Eq, Ord, Show)
instance DefinesTypes GType where
getDefinedTypes (BuiltinType _) = mempty
getDefinedTypes (DefinedType t) = getDefinedTypes t
instance HasName GType where
getName (DefinedType x) = getName x
getName (BuiltinType x) = getName x
data TypeDefinition = TypeDefinitionObject ObjectTypeDefinition
| TypeDefinitionInterface InterfaceTypeDefinition
| TypeDefinitionUnion UnionTypeDefinition
| TypeDefinitionScalar ScalarTypeDefinition
| TypeDefinitionEnum EnumTypeDefinition
| TypeDefinitionInputObject InputObjectTypeDefinition
| TypeDefinitionTypeExtension TypeExtensionDefinition
deriving (Eq, Ord, Show)
instance HasName TypeDefinition where
getName (TypeDefinitionObject x) = getName x
getName (TypeDefinitionInterface x) = getName x
getName (TypeDefinitionUnion x) = getName x
getName (TypeDefinitionScalar x) = getName x
getName (TypeDefinitionEnum x) = getName x
getName (TypeDefinitionInputObject x) = getName x
getName (TypeDefinitionTypeExtension x) = getName x
instance DefinesTypes TypeDefinition where
getDefinedTypes defn =
case defn of
TypeDefinitionObject x -> getDefinedTypes x
TypeDefinitionInterface x -> getDefinedTypes x
TypeDefinitionUnion x -> getDefinedTypes x
TypeDefinitionScalar x -> getDefinedTypes x
TypeDefinitionEnum x -> getDefinedTypes x
TypeDefinitionInputObject _ -> mempty
TypeDefinitionTypeExtension _ ->
panic "TODO: we should remove the 'extend' behaviour entirely"
data ObjectTypeDefinition = ObjectTypeDefinition Name Interfaces (NonEmpty FieldDefinition)
deriving (Eq, Ord, Show)
instance HasName ObjectTypeDefinition where
getName (ObjectTypeDefinition name _ _) = name
instance DefinesTypes ObjectTypeDefinition where
getDefinedTypes obj@(ObjectTypeDefinition name interfaces fields) =
Map.singleton name (TypeDefinitionObject obj) <>
foldMap getDefinedTypes interfaces <>
foldMap getDefinedTypes fields
type Interfaces = [InterfaceTypeDefinition]
data FieldDefinition = FieldDefinition Name [ArgumentDefinition] (AnnotatedType GType)
deriving (Eq, Ord, Show)
instance HasName FieldDefinition where
getName (FieldDefinition name _ _) = name
instance DefinesTypes FieldDefinition where
getDefinedTypes (FieldDefinition _ _ retVal) = getDefinedTypes (getAnnotatedType retVal)
data ArgumentDefinition = ArgumentDefinition Name (AnnotatedType InputType) (Maybe DefaultValue)
deriving (Eq, Ord, Show)
instance HasName ArgumentDefinition where
getName (ArgumentDefinition name _ _) = name
data InterfaceTypeDefinition = InterfaceTypeDefinition Name (NonEmpty FieldDefinition)
deriving (Eq, Ord, Show)
instance HasName InterfaceTypeDefinition where
getName (InterfaceTypeDefinition name _) = name
instance DefinesTypes InterfaceTypeDefinition where
getDefinedTypes i@(InterfaceTypeDefinition name fields) = Map.singleton name (TypeDefinitionInterface i) <> foldMap getDefinedTypes fields
data UnionTypeDefinition = UnionTypeDefinition Name (NonEmpty ObjectTypeDefinition)
deriving (Eq, Ord, Show)
instance HasName UnionTypeDefinition where
getName (UnionTypeDefinition name _) = name
instance DefinesTypes UnionTypeDefinition where
getDefinedTypes defn@(UnionTypeDefinition name objs) =
Map.singleton name (TypeDefinitionUnion defn) <>
foldMap getDefinedTypes objs
newtype ScalarTypeDefinition = ScalarTypeDefinition Name
deriving (Eq, Ord, Show)
instance HasName ScalarTypeDefinition where
getName (ScalarTypeDefinition name) = name
instance DefinesTypes ScalarTypeDefinition where
getDefinedTypes defn = Map.singleton (getName defn) (TypeDefinitionScalar defn)
-- | Types that are built into GraphQL.
--
-- The GraphQL spec refers to these as
-- \"[scalars](https://facebook.github.io/graphql/#sec-Scalars)\".
data Builtin
-- | A signed 32‐bit numeric non‐fractional value
= GInt
-- | True or false
| GBool
-- | Textual data represented as UTF-8 character sequences
| GString
-- | Signed double‐precision fractional values as specified by [IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point)
| GFloat
-- | A unique identifier, often used to refetch an object or as the key for a cache
| GID deriving (Eq, Ord, Show)
instance HasName Builtin where
getName GInt = "Int"
getName GBool = "Boolean"
getName GString = "String"
getName GFloat = "Float"
getName GID = "ID"
data EnumTypeDefinition = EnumTypeDefinition Name [EnumValueDefinition]
deriving (Eq, Ord, Show)
instance HasName EnumTypeDefinition where
getName (EnumTypeDefinition name _) = name
instance DefinesTypes EnumTypeDefinition where
getDefinedTypes enum = Map.singleton (getName enum) (TypeDefinitionEnum enum)
newtype EnumValueDefinition = EnumValueDefinition Name
deriving (Eq, Ord, Show)
instance HasName EnumValueDefinition where
getName (EnumValueDefinition name) = name
data InputObjectTypeDefinition = InputObjectTypeDefinition Name (NonEmpty InputObjectFieldDefinition)
deriving (Eq, Ord, Show)
instance HasName InputObjectTypeDefinition where
getName (InputObjectTypeDefinition name _) = name
data InputObjectFieldDefinition = InputObjectFieldDefinition Name (AnnotatedType InputType) (Maybe DefaultValue)
deriving (Eq, Ord, Show) -- XXX: spec is unclear about default value for input object field definitions
instance HasName InputObjectFieldDefinition where
getName (InputObjectFieldDefinition name _ _) = name
newtype TypeExtensionDefinition = TypeExtensionDefinition ObjectTypeDefinition
deriving (Eq, Ord, Show)
instance HasName TypeExtensionDefinition where
getName (TypeExtensionDefinition obj) = getName obj
data InputType = DefinedInputType InputTypeDefinition | BuiltinInputType Builtin deriving (Eq, Ord, Show)
instance HasName InputType where
getName (DefinedInputType x) = getName x
getName (BuiltinInputType x) = getName x
data InputTypeDefinition
= InputTypeDefinitionObject InputObjectTypeDefinition
| InputTypeDefinitionScalar ScalarTypeDefinition
| InputTypeDefinitionEnum EnumTypeDefinition
deriving (Eq, Ord, Show)
instance HasName InputTypeDefinition where
getName (InputTypeDefinitionObject x) = getName x
getName (InputTypeDefinitionScalar x) = getName x
getName (InputTypeDefinitionEnum x) = getName x
-- | A literal value specified as a default as part of a type definition.
--
-- Use this type alias when you want to be clear that a definition may include
-- some sort of default value.
--
-- Arguments (see 'ArgumentDefinition') and fields within input objects (see
-- 'InputObjectFieldDefinition') can have default values. These are allowed to
-- be any kind of literal.
type DefaultValue = Value
-- | Does the given object type match the given type condition.
--
-- See <https://facebook.github.io/graphql/#sec-Field-Collection>
--
-- @
-- DoesFragmentTypeApply(objectType, fragmentType)
-- If fragmentType is an Object Type:
-- if objectType and fragmentType are the same type, return true, otherwise return false.
-- If fragmentType is an Interface Type:
-- if objectType is an implementation of fragmentType, return true otherwise return false.
-- If fragmentType is a Union:
-- if objectType is a possible type of fragmentType, return true otherwise return false.
-- @
doesFragmentTypeApply :: ObjectTypeDefinition -> TypeDefinition -> Bool
doesFragmentTypeApply objectType fragmentType =
case fragmentType of
TypeDefinitionObject obj -> obj == objectType
TypeDefinitionInterface interface -> objectType `implements` interface
TypeDefinitionUnion union -> objectType `branchOf` union
_ -> False
where
implements (ObjectTypeDefinition _ interfaces _) int = int `elem` interfaces
branchOf obj (UnionTypeDefinition _ branches) = obj `elem` branches
-- | Convert the given TypeDefinition to an InputTypeDefinition if it's a valid InputTypeDefinition
-- (because InputTypeDefinition is a subset of TypeDefinition)
-- see <http://facebook.github.io/graphql/June2018/#sec-Input-and-Output-Types>
getInputTypeDefinition :: TypeDefinition -> Maybe InputTypeDefinition
getInputTypeDefinition td =
case td of
TypeDefinitionInputObject itd -> Just (InputTypeDefinitionObject itd)
TypeDefinitionScalar itd -> Just (InputTypeDefinitionScalar itd)
TypeDefinitionEnum itd -> Just (InputTypeDefinitionEnum itd)
_ -> Nothing