interface and union too

andreas · Feb 21, 2021 · d95b99e · d95b99e
1 parent a36529c
commit d95b99e
Show file tree

Hide file tree

Showing 3 changed files with 44 additions and 27 deletions.
diff --git a/graphql/src/graphql_intf.ml b/graphql/src/graphql_intf.ml
@@ -70,14 +70,6 @@ module type Schema = sig
     ('ctx, unit) field list ->
     'ctx schema
 
-  type 'a fixpoint = {
-    obj: 'ctx 'src 'typ 'b. ?doc:string -> string ->
-      fields:('a -> ('ctx, 'src) field list) ->
-     ('ctx, 'src option) typ
-  }
-
-  val fix : ('a fixpoint -> 'a) -> 'a
-
   type deprecated = NotDeprecated | Deprecated of string option
 
   val enum_value :
@@ -233,6 +225,20 @@ 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;
+
+    union : 'ctx. ?doc:string -> string -> ('ctx, 'a) abstract_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

diff --git a/graphql/src/graphql_schema.ml b/graphql/src/graphql_schema.ml
@@ -551,16 +551,35 @@ module Make (Io : IO) (Field_error : Field_error) = struct
   type 'a fixpoint = {
     obj: 'ctx 'src 'typ 'b. ?doc:string -> string ->
       fields:('a -> ('ctx, 'src) field list) ->
-     ('ctx, 'src option) typ
+      ('ctx, 'src option) typ;
+
+    union : 'ctx. ?doc:string -> string -> ('ctx, 'a) abstract_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)))
+      obj = (fun ?doc name ~fields ->
+        obj ?doc name ~fields:( lazy (fields (Lazy.force r))));
+
+      union;
+
+      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
@@ -629,14 +648,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 ->

diff --git a/graphql/test/abstract_test.ml b/graphql/test/abstract_test.ml
@@ -9,15 +9,15 @@ let meow : cat = { name = "Meow"; kittens = 1 }
 let fido : dog = { name = "Fido"; puppies = 2 }
 
 let cat =
-  Schema.(
-    obj "Cat" ~fields:[
-        field "name" ~typ:(non_null string)
-          ~args:Arg.[]
-          ~resolve:(fun _ (cat : cat) -> cat.name);
+  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);
-      ])
+        ~args:Arg.[]
+        ~resolve:(fun _ (cat : cat) -> cat.kittens);
+        ])))
 
 let dog =
   Schema.(