Skip to content

Commit

Permalink
Union and interface support.
Browse files Browse the repository at this point in the history
  • Loading branch information
@andreas
andreas committed Jul 11, 2018
1 parent bd121b2 commit fc83b7c
Show file tree
Hide file tree
Showing 5 changed files with 278 additions and 15 deletions.
24 changes: 24 additions & 0 deletions graphql/src/graphql_intf.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -110,6 +110,30 @@ module type Schema = sig

val non_null : ('ctx, 'src option) typ -> ('ctx, 'src) typ

type ('ctx, 'a) abstract_value
type ('ctx, 'a) abstract_typ = ('ctx, ('ctx, 'a) abstract_value option) typ

val union : ?doc:string ->
string ->
('ctx, 'a) abstract_typ

type abstract_field
val abstract_field : ?doc:string ->
?deprecated:deprecated ->
string ->
typ:(_, 'a) typ ->
args:('a, _) Arg.arg_list ->
abstract_field

val interface : ?doc:string ->
string ->
fields:(('ctx, 'a) abstract_typ -> abstract_field list) ->
('ctx, 'a) abstract_typ

val add_type : ('ctx, 'a) abstract_typ ->
('ctx, 'src option) typ ->
'src -> ('ctx, 'a) abstract_value

(** {3 Built-in scalars} *)

val int : ('ctx, int option) typ
Expand Down
98 changes: 84 additions & 14 deletions graphql/src/graphql_schema.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -296,6 +296,7 @@ module Make(Io : IO) = struct
name : string;
doc : string option;
fields : ('ctx, 'src) field list Lazy.t;
abstracts : abstract list ref;
}
and (_, _) field =
Field : {
Expand All @@ -313,6 +314,22 @@ module Make(Io : IO) = struct
| NonNullable : ('ctx, 'src option) typ -> ('ctx, 'src) typ
| Scalar : 'src scalar -> ('ctx, 'src option) typ
| Enum : 'src enum -> ('ctx, 'src option) typ
| Abstract : abstract -> ('ctx, ('ctx, 'a) abstract_value option) typ
and any_typ =
| AnyTyp : (_, _) typ -> any_typ
| AnyArgTyp : _ Arg.arg_typ -> any_typ
and abstract = {
name : string;
doc : string option;
kind : [`Union | `Interface of abstract_field list Lazy.t];
mutable types : any_typ list;
}
and abstract_field =
AbstractField : (_, _) field -> abstract_field
and ('ctx, 'a) abstract_value =
AbstractValue : ('ctx, 'src option) typ * 'src -> ('ctx, 'a) abstract_value

type ('ctx, 'a) abstract_typ = ('ctx, ('ctx, 'a) abstract_value option) typ

type 'ctx schema = {
query : ('ctx, unit) obj;
Expand All @@ -323,20 +340,22 @@ module Make(Io : IO) = struct
query = {
name = query_name;
doc = None;
abstracts = ref [];
fields = lazy fields;
};
mutation = Option.map mutations ~f:(fun fields ->
{
name = mutation_name;
doc = None;
abstracts = ref [];
fields = lazy fields;
}
)
}

(* Constructor functions *)
let obj ?doc name ~fields =
let rec o = Object { name; doc; fields = lazy (fields o)} in
let rec o = Object { name; doc; fields = lazy (fields o); abstracts = ref []} in
o

let field ?doc ?(deprecated=NotDeprecated) name ~typ ~args ~resolve =
Expand All @@ -345,6 +364,9 @@ module Make(Io : IO) = struct
let io_field ?doc ?(deprecated=NotDeprecated) name ~typ ~args ~resolve =
Field { name; doc; deprecated; typ; args; resolve; lift = id }

let abstract_field ?doc ?(deprecated=NotDeprecated) name ~typ ~args =
AbstractField (Field { lift = Io.ok; name; doc; deprecated; typ; args; resolve = Obj.magic () })

let enum ?doc name ~values =
Enum { name; doc; values }

Expand All @@ -357,6 +379,23 @@ module Make(Io : IO) = struct
let non_null typ =
NonNullable typ

let union ?doc name =
Abstract { name; doc; types = []; kind = `Union }

let interface ?doc name ~fields =
let rec i = Abstract { name; doc; types = []; kind = `Interface (lazy (fields i)) } in
i

let add_type abstract_typ typ =
match (abstract_typ, typ) with
| Abstract a, Object o ->
(* TODO add subtype check here *)
a.types <- (AnyTyp typ)::a.types;
o.abstracts := a :: !(o.abstracts);
fun src -> AbstractValue (typ, src)
| _ ->
invalid_arg "Arguments must be Interface/Union and Object"

(* Built-in scalars *)
let int : 'ctx. ('ctx, int option) typ = Scalar {
name = "Int";
Expand Down Expand Up @@ -390,9 +429,6 @@ module Make(Io : IO) = struct

module Introspection = struct
(* any_typ, any_field and any_arg hide type parameters to avoid scope escaping errors *)
type any_typ =
| AnyTyp : (_, _) typ -> any_typ
| AnyArgTyp : _ Arg.arg_typ -> any_typ
type any_field =
| AnyField : (_, _) field -> any_field
| AnyArgField : _ Arg.arg -> any_field
Expand All @@ -406,7 +442,7 @@ module Introspection = struct
f (result, visited)

(* Extracts all types contained in a single type *)
let rec types : type src. ?memo:(any_typ list * StringSet.t) -> ('ctx, src) typ -> (any_typ list * StringSet.t) = fun ?(memo=([], StringSet.empty)) typ ->
let rec types : type ctx src. ?memo:(any_typ list * StringSet.t) -> (ctx, src) typ -> (any_typ list * StringSet.t) = fun ?(memo=([], StringSet.empty)) typ ->
match typ with
| List typ -> types ~memo typ
| NonNullable typ -> types ~memo typ
Expand All @@ -428,6 +464,13 @@ module Introspection = struct
in
List.fold_left reducer (result', visited') (Lazy.force o.fields)
)
| Abstract a as abstract ->
unless_visited memo a.name (fun (result, visited) ->
let result' = (AnyTyp abstract)::result in
let visited' = StringSet.add a.name visited in
List.fold_left (fun memo (AnyTyp typ) -> types ~memo typ) (result', visited') a.types
)

and arg_types : type a. (any_typ list * StringSet.t) -> a Arg.arg_typ -> (any_typ list * StringSet.t) = fun memo argtyp ->
match argtyp with
| Arg.List typ -> arg_types memo typ
Expand Down Expand Up @@ -464,6 +507,8 @@ module Introspection = struct
let memo' = List.cons (AnyArg arg) memo in
args_to_list ~memo:memo' args

let no_abstracts = ref []

let __type_kind = Enum {
name = "__TypeKind";
doc = None;
Expand Down Expand Up @@ -522,6 +567,7 @@ module Introspection = struct
let __enum_value : 'ctx. ('ctx, any_enum_value option) typ = Object {
name = "__EnumValue";
doc = None;
abstracts = no_abstracts;
fields = lazy [
Field {
name = "name";
Expand Down Expand Up @@ -568,6 +614,7 @@ module Introspection = struct
let rec __input_value : 'ctx. ('ctx, any_arg option) typ = Object {
name = "__InputValue";
doc = None;
abstracts = no_abstracts;
fields = lazy [
Field {
name = "name";
Expand Down Expand Up @@ -617,6 +664,7 @@ module Introspection = struct
and __type : 'ctx . ('ctx, any_typ option) typ = Object {
name = "__Type";
doc = None;
abstracts = no_abstracts;
fields = lazy [
Field {
name = "kind";
Expand All @@ -627,6 +675,8 @@ module Introspection = struct
lift = Io.ok;
resolve = fun _ t -> match t with
| AnyTyp (Object _) -> `Object
| AnyTyp (Abstract { kind = `Union; _ }) -> `Union
| AnyTyp (Abstract { kind = `Interface _; _ }) -> `Interface
| AnyTyp (List _) -> `List
| AnyTyp (Scalar _) -> `Scalar
| AnyTyp (Enum _) -> `Enum
Expand All @@ -648,6 +698,7 @@ module Introspection = struct
| AnyTyp (Object o) -> Some o.name
| AnyTyp (Scalar s) -> Some s.name
| AnyTyp (Enum e) -> Some e.name
| AnyTyp (Abstract a) -> Some a.name
| AnyArgTyp (Arg.Object o) -> Some o.name
| AnyArgTyp (Arg.Scalar s) -> Some s.name
| AnyArgTyp (Arg.Enum e) -> Some e.name
Expand All @@ -664,6 +715,7 @@ module Introspection = struct
| AnyTyp (Object o) -> o.doc
| AnyTyp (Scalar s) -> s.doc
| AnyTyp (Enum e) -> e.doc
| AnyTyp (Abstract a) -> a.doc
| AnyArgTyp (Arg.Object o) -> o.doc
| AnyArgTyp (Arg.Scalar s) -> s.doc
| AnyArgTyp (Arg.Enum e) -> e.doc
Expand All @@ -679,6 +731,8 @@ module Introspection = struct
resolve = fun _ t -> match t with
| AnyTyp (Object o) ->
Some (List.map (fun f -> AnyField f) (Lazy.force o.fields))
| AnyTyp (Abstract { kind = `Interface fields; _ }) ->
Some (List.map (fun (AbstractField f) -> AnyField f) (Lazy.force fields))
| AnyArgTyp (Arg.Object o) ->
let arg_list = args_to_list o.fields in
Some (List.map (fun (AnyArg f) -> AnyArgField f) arg_list)
Expand All @@ -688,21 +742,26 @@ module Introspection = struct
name = "interfaces";
doc = None;
deprecated = NotDeprecated;
typ = List __type;
typ = List (NonNullable __type);
args = Arg.[];
lift = Io.ok;
resolve = fun _ t -> match t with
| AnyTyp (Object _) -> Some []
| AnyTyp (Object o) ->
let interfaces = List.filter (function | { kind = `Interface _; _} -> true | _ -> false) !(o.abstracts) in
Some (List.map (fun i -> AnyTyp (Abstract i)) interfaces)
| _ -> None
};
Field {
name = "possibleTypes";
doc = None;
deprecated = NotDeprecated;
typ = List __type;
typ = List (NonNullable __type);
args = Arg.[];
lift = Io.ok;
resolve = fun _ t -> None
resolve = fun _ t -> match t with
| AnyTyp (Abstract a) ->
Some a.types
| _ -> None
};
Field {
name = "ofType";
Expand Down Expand Up @@ -748,6 +807,7 @@ module Introspection = struct
and __field : 'ctx. ('ctx, any_field option) typ = Object {
name = "__Field";
doc = None;
abstracts = no_abstracts;
fields = lazy [
Field {
name = "name";
Expand Down Expand Up @@ -824,6 +884,7 @@ module Introspection = struct
let __directive = Object {
name = "__Directive";
doc = None;
abstracts = no_abstracts;
fields = lazy [
Field {
name = "name";
Expand All @@ -840,6 +901,7 @@ module Introspection = struct
let __schema : 'ctx. ('ctx, 'ctx schema option) typ = Object {
name = "__Schema";
doc = None;
abstracts = no_abstracts;
fields = lazy [
Field {
name = "types";
Expand Down Expand Up @@ -909,13 +971,17 @@ end
ctx : 'ctx;
}

let matches_type_condition type_condition obj =
obj.name = type_condition ||
List.exists (fun (abstract : abstract) -> abstract.name = type_condition) !(obj.abstracts)

let rec collect_fields : fragment_map -> ('ctx, 'src) obj -> Graphql_parser.selection list -> Graphql_parser.field list = fun fragment_map obj fields ->
List.map (function
| Graphql_parser.Field field ->
[field]
| Graphql_parser.FragmentSpread spread ->
begin match StringMap.find spread.name fragment_map with
| Some fragment when obj.name = fragment.type_condition ->
| Some fragment when matches_type_condition fragment.type_condition obj ->
collect_fields fragment_map obj fragment.selection_set
| _ ->
[]
Expand All @@ -924,7 +990,7 @@ end
match fragment.type_condition with
| None ->
collect_fields fragment_map obj fragment.selection_set
| Some condition when condition = obj.name ->
| Some condition when matches_type_condition condition obj ->
collect_fields fragment_map obj fragment.selection_set
| _ -> []
) fields
Expand All @@ -948,7 +1014,7 @@ end
| Serial -> Io.map_s ~memo:[]
| Parallel -> Io.map_p

let rec present : type src. 'ctx execution_context -> src -> Graphql_parser.field -> ('ctx, src) typ -> (Yojson.Basic.json * string list, [`Argument_error of string | `Resolve_error of string]) result Io.t =
let rec present : type ctx src. ctx execution_context -> src -> Graphql_parser.field -> (ctx, src) typ -> (Yojson.Basic.json * string list, [`Argument_error of string | `Resolve_error of string]) result Io.t =
fun ctx src query_field typ ->
match typ with
| Scalar s -> coerce_or_null src (fun x -> Io.ok (s.coerce x, []))
Expand All @@ -971,8 +1037,12 @@ end
| Some enum_value -> Io.ok (`String enum_value.name, [])
| None -> Io.ok (`Null, [])
)
| Abstract u ->
coerce_or_null src (fun (AbstractValue (typ', src')) ->
present ctx (Some src') query_field typ'
)

and resolve_field : type src. 'ctx execution_context -> src -> Graphql_parser.field -> ('ctx, src) field -> ((string * Yojson.Basic.json) * string list, [`Argument_error of string | `Resolve_error of string]) result Io.t =
and resolve_field : type ctx src. ctx execution_context -> src -> Graphql_parser.field -> (ctx, src) field -> ((string * Yojson.Basic.json) * string list, [`Argument_error of string | `Resolve_error of string]) result Io.t =
fun ctx src query_field (Field field) ->
let open Io.Infix in
let name = alias_or_name query_field in
Expand All @@ -999,7 +1069,7 @@ end
| Error err ->
Io.error (`Argument_error err)

and resolve_fields : type src. 'ctx execution_context -> ?execution_order:execution_order -> src -> ('ctx, src) obj -> Graphql_parser.field list -> (Yojson.Basic.json * string list, [`Argument_error of string | `Resolve_error of string]) result Io.t =
and resolve_fields : type ctx src. ctx execution_context -> ?execution_order:execution_order -> src -> (ctx, src) obj -> Graphql_parser.field list -> (Yojson.Basic.json * string list, [`Argument_error of string | `Resolve_error of string]) result Io.t =
fun ctx ?execution_order:(execution_order=Parallel) src obj fields ->
map_fields_with_order execution_order (fun (query_field : Graphql_parser.field) ->
if query_field.name = "__typename" then
Expand Down
Loading

0 comments on commit fc83b7c

Please sign in to comment.