Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Recursive fields: add Arg.fix and Schema.fix #199

Merged
merged 5 commits into from
Mar 29, 2021
Merged
Show file tree
Hide file tree
Changes from 1 commit
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
4 changes: 3 additions & 1 deletion dune-project
Original file line number Diff line number Diff line change
@@ -1,3 +1,5 @@
(lang dune 1.1)
(lang dune 1.11)

(using menhir 2.0)

(using fmt 1.2)
21 changes: 20 additions & 1 deletion graphql/src/graphql_intf.ml
Original file line number Diff line number Diff line change
Expand Up @@ -70,6 +70,14 @@ module type Schema = sig
('ctx, unit) field list ->
'ctx schema

type ('ctx, 'src,'a) recursive = {
obj: ?doc:string -> string ->
fields:('a -> ('ctx, 'src) field list) ->
('ctx, 'src option) typ
}

val fix : (('ctx, 'src, 'a) recursive -> 'a) -> 'a

type deprecated = NotDeprecated | Deprecated of string option

val enum_value :
Expand All @@ -82,7 +90,7 @@ module type Schema = sig
val obj :
?doc:string ->
string ->
fields:(('ctx, 'src option) typ -> ('ctx, 'src) field list) ->
fields:('ctx, 'src) field list ->
('ctx, 'src option) typ

module Arg : sig
Expand All @@ -103,6 +111,17 @@ module type Schema = sig
default:Graphql_parser.const_value ->
'a arg

type ('t, 'args,'a) recursive = {
obj
: ?doc:string
-> string
-> fields:('a -> ('t, 'args) arg_list)
-> coerce:'args
-> 't option arg_typ
}

val fix : (('ctx, 'src, 'a) recursive -> 'a) -> 'a

val scalar :
?doc:string ->
string ->
Expand Down
47 changes: 40 additions & 7 deletions graphql/src/graphql_schema.ml
Original file line number Diff line number Diff line change
Expand Up @@ -175,6 +175,26 @@ module Make (Io : IO) (Field_error : Field_error) = struct
| [] : ('a, 'a) arg_list
| ( :: ) : 'a arg * ('b, 'c) arg_list -> ('b, 'a -> 'c) arg_list

type ('t, 'args,'a) recursive = {
obj
: ?doc:string
-> string
-> fields:('a -> ('t, 'args) arg_list)
-> coerce:'args
-> 't option arg_typ
}

let obj ?doc name ~fields ~coerce =
Object { name; doc; fields; coerce }

let fix : (('ctx, 'src, 'a) recursive -> 'a) -> 'a = fun f ->
let rec recursive = {
obj = fun ?doc name ~fields ->
obj ?doc name ~fields:(lazy (fields (Lazy.force r)))
}
and r = lazy (f recursive)
in Lazy.force r

let rec string_of_const_value : Graphql_parser.const_value -> string =
function
| `Null -> Yojson.Basic.to_string `Null
Expand Down Expand Up @@ -421,8 +441,8 @@ module Make (Io : IO) (Field_error : Field_error) = struct

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

let obj ?doc name ~fields ~coerce = Object { name; doc; fields; coerce }

let obj ?doc name ~fields ~coerce =
obj ?doc name ~fields:(lazy fields) ~coerce
end

(* Schema data types *)
Expand Down Expand Up @@ -528,6 +548,23 @@ module Make (Io : IO) (Field_error : Field_error) = struct
}
-> directive

type ('ctx, 'src,'a) recursive = {
obj: ?doc:string -> string ->
fields:('a -> ('ctx, 'src) field list) ->
('ctx, 'src option) typ
}

let obj ?doc name ~fields =
Object { name; doc; fields; abstracts = ref [] }

let fix : (('ctx, 'src, 'a) recursive -> 'a) -> 'a = fun f ->
let rec recursive = {
obj = fun ?doc name ~fields ->
obj ?doc name ~fields:( lazy (fields (Lazy.force r)))
}
and r = lazy (f recursive)
in Lazy.force r

type 'ctx schema = {
query : ('ctx, unit) obj;
mutation : ('ctx, unit) obj option;
Expand Down Expand Up @@ -559,11 +596,7 @@ module Make (Io : IO) (Field_error : Field_error) = struct
}

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

let field ?doc ?(deprecated = NotDeprecated) name ~typ ~args ~resolve =
Field { name; doc; deprecated; typ; args; resolve; lift = Io.ok }
Expand Down
34 changes: 16 additions & 18 deletions graphql/test/abstract_test.ml
Original file line number Diff line number Diff line change
Expand Up @@ -10,27 +10,25 @@ let fido : dog = { name = "Fido"; puppies = 2 }

let cat =
Schema.(
obj "Cat" ~fields:(fun _ ->
[
field "name" ~typ:(non_null string)
~args:Arg.[]
~resolve:(fun _ (cat : cat) -> cat.name);
field "kittens" ~typ:(non_null int)
~args:Arg.[]
~resolve:(fun _ (cat : cat) -> cat.kittens);
]))
obj "Cat" ~fields:[
field "name" ~typ:(non_null string)
~args:Arg.[]
~resolve:(fun _ (cat : cat) -> cat.name);
field "kittens" ~typ:(non_null int)
~args:Arg.[]
~resolve:(fun _ (cat : cat) -> cat.kittens);
])

let dog =
Schema.(
obj "Dog" ~fields:(fun _ ->
[
field "name" ~typ:(non_null string)
~args:Arg.[]
~resolve:(fun _ (dog : dog) -> dog.name);
field "puppies" ~typ:(non_null int)
~args:Arg.[]
~resolve:(fun _ (dog : dog) -> dog.puppies);
]))
obj "Dog" ~fields:[
field "name" ~typ:(non_null string)
~args:Arg.[]
~resolve:(fun _ (dog : dog) -> dog.name);
field "puppies" ~typ:(non_null int)
~args:Arg.[]
~resolve:(fun _ (dog : dog) -> dog.puppies);
])

let pet : (unit, [ `pet ]) Schema.abstract_typ = Schema.union "Pet"

Expand Down
3 changes: 1 addition & 2 deletions graphql/test/echo_schema.ml
Original file line number Diff line number Diff line change
Expand Up @@ -23,8 +23,7 @@ let color_enum_arg = Schema.Arg.enum "color" ~values:color_enum_values
let person_arg =
Schema.Arg.(
obj "person"
~fields:
[
~fields:[
arg "title" ~typ:string;
arg "first_name" ~typ:(non_null string);
arg "last_name" ~typ:(non_null string);
Expand Down
24 changes: 11 additions & 13 deletions graphql/test/error_test.ml
Original file line number Diff line number Diff line change
Expand Up @@ -62,12 +62,11 @@ let suite =
fun () ->
let obj_with_non_nullable_field =
Schema.(
obj "obj" ~fields:(fun _ ->
[
io_field "non_nullable" ~typ:(non_null int)
~args:Arg.[]
~resolve:(fun _ () -> Error "boom");
]))
obj "obj" ~fields: [
io_field "non_nullable" ~typ:(non_null int)
~args:Arg.[]
~resolve:(fun _ () -> Error "boom");
])
in
let schema =
Schema.(
Expand Down Expand Up @@ -100,13 +99,12 @@ let suite =
fun () ->
let foo =
Schema.(
obj "Foo" ~fields:(fun _ ->
[
io_field "id" ~typ:int
~args:Arg.[]
~resolve:(fun _ (id, should_fail) ->
if should_fail then Error "boom" else Ok (Some id));
]))
obj "Foo" ~fields:[
io_field "id" ~typ:int
~args:Arg.[]
~resolve:(fun _ (id, should_fail) ->
if should_fail then Error "boom" else Ok (Some id));
])
in
let schema =
Schema.(
Expand Down
12 changes: 12 additions & 0 deletions graphql/test/schema_test.ml
Original file line number Diff line number Diff line change
Expand Up @@ -329,6 +329,18 @@ let suite =
match Graphql.Schema.execute Test_schema.schema () doc with
| Ok _ -> ()
| Error err -> failwith (Yojson.Basic.pretty_to_string err) ) );

( "recursive schema",
`Quick,
fun () ->
let query = "query a { tree { children { element } } }" in
test_query query
(`Assoc
[
( "data",
`Assoc [ ("tree", `Assoc [ "children", `List [
`Assoc ["element", `Int 1] ] ]) ]); ]));

( "subscription",
`Quick,
fun () ->
Expand Down
3 changes: 1 addition & 2 deletions graphql/test/test_common.ml
Original file line number Diff line number Diff line change
Expand Up @@ -2,8 +2,7 @@ let yojson =
( module struct
type t = Yojson.Basic.json

let pp formatter t =
Format.pp_print_text formatter (Yojson.Basic.pretty_to_string t)
let pp = Yojson.Basic.pretty_print ?std:None
Copy link
Contributor Author

@anmonteiro anmonteiro Feb 20, 2021

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

drive-by change for better diffs when testing


let equal = ( = )
end : Alcotest.TESTABLE
Expand Down
49 changes: 37 additions & 12 deletions graphql/test/test_schema.ml
Original file line number Diff line number Diff line change
Expand Up @@ -20,18 +20,40 @@ let input_role = Schema.Arg.(enum "role" ~values:role_values)

let user =
Schema.(
obj "user" ~fields:(fun _ ->
[
field "id" ~typ:(non_null int)
~args:Arg.[]
~resolve:(fun { ctx = () } p -> p.id);
field "name" ~typ:(non_null string)
~args:Arg.[]
~resolve:(fun _ p -> p.name);
field "role" ~typ:(non_null role)
~args:Arg.[]
~resolve:(fun _ p -> p.role);
]))
obj "user" ~fields:[
field "id" ~typ:(non_null int)
~args:Arg.[]
~resolve:(fun { ctx = () } p -> p.id);
field "name" ~typ:(non_null string)
~args:Arg.[]
~resolve:(fun _ p -> p.name);
field "role" ~typ:(non_null role)
~args:Arg.[]
~resolve:(fun _ p -> p.role);
])

type tree = | Node of (int * tree list) | Leaf of int

let node, leaf = Schema.(fix (fun (recursive) ->
recursive.obj "Node"
~fields:(fun (node, _leaf) -> [
field "children"
~typ:(non_null (list (non_null node)))
~args:[]
~resolve:(fun { ctx = () } t -> match t with | Node (_, xs) -> xs | Leaf _ -> []);
field "element"
~typ:(non_null int)
~args:[]
~resolve:(fun { ctx = () } t -> match t with Node (el, _) | Leaf el -> el)
]),
recursive.obj "Leaf"
~fields:(fun (_node, _leaf) -> [
field "element"
~typ:(non_null int)
~args:[]
~resolve:(fun { ctx = () } t -> match t with Node (el, _) | Leaf el -> el)
])
))

(* Not available in List before OCaml 4.07 *)
let list_to_seq n l =
Expand All @@ -46,6 +68,9 @@ let schema =
Schema.(
schema
[
field "tree" ~typ:(non_null node) ~args:[] ~resolve:(fun _ () ->
Node (0, [ Node (1, [Leaf 2]) ]));

field "users"
~typ:(non_null (list (non_null user)))
~args:Arg.[]
Expand Down