Merge pull request #199 from anmonteiro/anmonteiro/recursive-args-fix

Recursive fields: add `Arg.fix` and `Schema.fix`

README.md

@@ -136,40 +136,42 @@ type tweet = {
   replies : tweet list;
 }
 
-let tweet = Schema.(obj "tweet"
-  ~fields:(fun tweet -> [
-    field "id"
-      ~typ:(non_null int)
-      ~args:Arg.[]
-      ~resolve:(fun info t -> t.id)
-    ;
-    field "replies"
-      ~typ:(non_null (list tweet))
-      ~args:Arg.[]
-      ~resolve:(fun info t -> t.replies)
-  ])
-)
+let tweet = Schema.(fix (fun recursive ->
+  recursive.obj "tweet"
+    ~fields:(fun tweet -> [
+      field "id"
+        ~typ:(non_null int)
+        ~args:Arg.[]
+        ~resolve:(fun info t -> t.id)
+        ;
+      field "replies"
+        ~typ:(non_null (list (non_null tweet)))
+        ~args:Arg.[]
+        ~resolve:(fun info t -> t.replies)
+    ])))
 ```
 
 ### Mutually Recursive Objects
 
 Mutually recursive objects can be defined using `let rec` and `lazy`:
 
 ```ocaml
-let rec foo = lazy Schema.(obj "foo"
-  ~fields:(fun _ -> [
-    field "bar"
-      ~typ:Lazy.(force bar)
-      ~args.Arg.[]
-      ~resolve:(fun info foo -> foo.bar)
-  ])
-and bar = lazy Schema.(obj "bar"
-  ~fields:(fun _ -> [
+let foo, bar = Schema.(fix (fun recursive ->
+  let foo = recursive.obj "foo" ~fields:(fun (_, bar) -> [
+      field "bar"
+        ~typ:bar
+        ~args:Arg.[]
+        ~resolve:(fun info foo -> foo.bar)
+    ])
+  in
+  let bar = recursive.obj "bar" ~fields:(fun (foo, _) -> [
     field "foo"
-      ~typ:Lazy.(force foo)
-      ~args.Arg.[]
+      ~typ:foo
+      ~args:Arg.[]
       ~resolve:(fun info bar -> bar.foo)
-  ])
+      ])
+  in
+  foo, bar))
 ```
 
 ### Lwt Support

dune-project

@@ -1,3 +1,5 @@
-(lang dune 1.1)
+(lang dune 1.11)
+
 (using menhir 2.0)
+
 (using fmt 1.2)

graphql/src/graphql_intf.ml

@@ -82,7 +82,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
@@ -103,6 +103,17 @@ module type Schema = sig
       default:Graphql_parser.const_value ->
       'a arg
 
+    type 'a fixpoint = {
+      obj: 'src 't 'args.
+          ?doc:string
+          -> string
+          -> fields:('a -> ('t, 'args) arg_list)
+          -> coerce:'args
+          -> 't option arg_typ
+    }
+
+    val fix : ('a fixpoint -> 'a) -> 'a
+
     val scalar :
       ?doc:string ->
       string ->
@@ -214,6 +225,18 @@ module type Schema = sig
     'src ->
     ('ctx, 'a) abstract_value
 
+  type 'a fixpoint = {
+    obj: 'ctx 'src 'typ 'b. ?doc:string -> string ->
+      fields:('a -> ('ctx, 'src) field list) ->
+      ('ctx, 'src option) typ;
+
+    interface : 'ctx 'src. ?doc:string -> string ->
+      fields:('a -> abstract_field list) ->
+      ('ctx, 'src) abstract_typ
+  }
+
+  val fix : ('a fixpoint -> 'a) -> 'a
+
   (** {3 Built-in scalars} *)
 
   val int : ('ctx, int option) typ

graphql/src/graphql_schema.ml

@@ -142,7 +142,7 @@ module Make (Io : IO) (Field_error : Field_error) = struct
       | Object : {
           name : string;
           doc : string option;
-          fields : ('a, 'b) arg_list;
+          fields : ('a, 'b) arg_list Lazy.t;
           coerce : 'b;
         }
           -> 'a option arg_typ
@@ -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 'a fixpoint = {
+      obj: 'src 't 'args.
+          ?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 : ('a fixpoint -> '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
@@ -350,7 +370,7 @@ module Make (Io : IO) (Field_error : Field_error) = struct
           match value with
           | `Assoc props ->
               let props' = (props :> (string * Graphql_parser.value) list) in
-              eval_arglist variable_map ?field_type ~field_name o.fields props'
+              eval_arglist variable_map ?field_type ~field_name (Lazy.force o.fields) props'
                 o.coerce
               >>| fun coerced -> Some coerced
           | _ ->
@@ -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 *)
@@ -528,6 +548,38 @@ module Make (Io : IO) (Field_error : Field_error) = struct
       }
         -> directive
 
+  type 'a fixpoint = {
+    obj: 'ctx 'src 'typ 'b. ?doc:string -> string ->
+      fields:('a -> ('ctx, 'src) field list) ->
+      ('ctx, 'src option) typ;
+
+    interface : 'ctx 'src. ?doc:string -> string ->
+      fields:('a -> abstract_field list) ->
+      ('ctx, 'src) abstract_typ
+  }
+
+  let obj ?doc name ~fields =
+    Object { name; doc; fields; abstracts = ref [] }
+
+  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 fix f =
+    let rec recursive = {
+      obj = (fun ?doc name ~fields ->
+        obj ?doc name ~fields:( lazy (fields (Lazy.force r))));
+
+      interface = fun ?doc name ~fields ->
+        Abstract { name; doc; types = []; kind = `Interface (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;
@@ -559,11 +611,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 }
@@ -596,14 +644,6 @@ module Make (Io : IO) (Field_error : Field_error) = 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 ->
@@ -745,7 +785,7 @@ module Make (Io : IO) (Field_error : Field_error) = struct
               let memo' =
                 (AnyArgTyp obj :: result, StringSet.add o.name visited)
               in
-              arg_list_types memo' o.fields)
+              arg_list_types memo' (Lazy.force o.fields))
 
     and arg_list_types :
         type a b.
@@ -1071,7 +1111,7 @@ module Make (Io : IO) (Field_error : Field_error) = struct
                                  (fun (AbstractField f) -> AnyField f)
                                  (Lazy.force fields))
                         | AnyArgTyp (Arg.Object o) ->
-                            let arg_list = args_to_list o.fields in
+                            let arg_list = args_to_list (Lazy.force o.fields) in
                             Some
                               (List.map
                                  (fun (AnyArg f) -> AnyArgField f)
@@ -1147,7 +1187,7 @@ module Make (Io : IO) (Field_error : Field_error) = struct
                       (fun _ t ->
                         match t with
                         | AnyArgTyp (Arg.Object o) ->
-                            Some (args_to_list o.fields)
+                            Some (args_to_list (Lazy.force o.fields))
                         | _ -> None);
                   };
                 Field

graphql/test/abstract_test.ml

@@ -9,28 +9,26 @@ let meow : cat = { name = "Meow"; kittens = 1 }
 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);
-        ]))
+  Schema.(fix (fun fixpoint ->
+    fixpoint.obj "Cat" ~fields:(fun _self -> [
+      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"
 

graphql/test/echo_schema.ml

@@ -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);

graphql/test/error_test.ml

@@ -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.(
@@ -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.(

graphql/test/schema_test.ml

@@ -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 () ->

graphql/test/test_common.ml

@@ -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
 
     let equal = ( = )
   end : Alcotest.TESTABLE