Expose Query.t as the resulting type of decoding the query

mhallin · Jan 20, 2018 · 50d0fd2 · 50d0fd2
1 parent 928e16e
commit 50d0fd2
Show file tree

Hide file tree

Showing 17 changed files with 121 additions and 90 deletions.
diff --git a/src/graphql_ppx.ml b/src/graphql_ppx.ml
@@ -94,6 +94,11 @@ let mapper () =
                       [%stri exception Graphql_error];
                       [%stri let query = [%e Exp.constant ~loc (Const_string (reprinted_query, delim))]];
                       [%stri let parse = fun value -> [%e parse_fn]];
+                      [%stri module type mt = sig type t end];
+                      [%stri type 'a typed = (module mt with type t = 'a)];
+                      [%stri let ret_type (type a) (f: _ -> a) = (let module MT = struct type t = a end in (module MT): a typed)];
+                      [%stri module MT = (val ret_type parse)];
+                      [%stri type t = MT.t];
                       {
                         pstr_desc = (Pstr_value (rec_flag, encoders));
                         pstr_loc = loc

diff --git a/src/result_decoder.ml b/src/result_decoder.ml
@@ -114,14 +114,27 @@ and unify_union map_loc span schema union_meta selection_set =
       else 
         Ast_helper.Exp.case [%pat? Some _ ] [%expr `Nonexhaustive ]
     in
+    let union_ty = Ast_helper.(
+      Typ.variant ~loc:loc
+        (let case_variants = List.map(fun evm_name -> Rtag (evm_name, [], false, [{ ptyp_desc = Ptyp_any; ptyp_attributes = []; ptyp_loc = loc }])) covered_cases
+        in if covered_cases = possible_cases
+          then case_variants
+          else Rtag ("Nonexhaustive", [], true, []) :: case_variants)
+        Closed None)
+    in
     let decoder = Ast_helper.Exp.match_ ~loc typename_decode (List.append (List.map generate_case fragments) [fail_case; none_case]) in
     [%expr match Js.Json.decodeObject value with
       | None -> raise Graphql_error
-      | Some unionValue -> [%e decoder]] [@metaloc loc]
+      | Some unionValue -> ([%e decoder]: [%t union_ty])] [@metaloc loc]
 
 
 and unify_variant map_loc span ty schema selection_set =
   let loc = map_loc span in
+  let selection_name = function
+    | Field { item } -> String.capitalize (some_or item.fd_alias item.fd_name).item
+    | FragmentSpread { span } -> raise_error map_loc span "Variant selections can only contain fields"
+    | InlineFragment { span } -> raise_error map_loc span "Variant selections can only contain fields"
+  in
   let rec match_loop ty selection_set = match selection_set with
     | [] -> [%expr raise Graphql_error] [@metaloc loc]
     | Field { item; span } :: tl -> begin
@@ -164,11 +177,16 @@ and unify_variant map_loc span ty schema selection_set =
     | Some InputObject _ -> raise_error map_loc span "Variant fields can only be applied to object types"
     | Some ((Object _) as ty) ->
       match selection_set with
+      | None -> raise_error map_loc span "Variant fields need a selection set"
       | Some { item } ->
+        let matcher = match_loop ty item in
+        let variant_type = Ast_helper.(
+          Typ.variant ~loc:loc
+            (List.map(fun s -> Rtag (selection_name s, [], false, [{ ptyp_desc = Ptyp_any; ptyp_attributes = []; ptyp_loc = loc }])) item)
+            Closed None) in
         [%expr match Js.Json.decodeObject value with
           | None -> raise Graphql_error
-          | Some value -> [%e match_loop ty item]] [@metaloc loc]
-      | None -> raise_error map_loc span "Variant fields need a selection set"
+          | Some value -> ([%e matcher]: [%t variant_type])] [@metaloc loc]
 
 and unify_field map_loc field_span ty schema =
   let ast_field = field_span.item in

diff --git a/tests/types/customDecoder.rei b/tests/types/customDecoder.rei
@@ -1,9 +1,10 @@
 module MyQuery: {
+  type t = Js.t {. variousScalars : Js.t {. string : int, int : string}};
   let make:
     unit =>
     Js.t {
       .
-      parse : Js.Json.t => Js.t {. variousScalars : Js.t {. string : int, int : string}},
+      parse : Js.Json.t => t,
       query : string,
       variables : Js.Json.t
     };

diff --git a/tests/types/lists.rei b/tests/types/lists.rei
@@ -1,21 +1,19 @@
 module MyQuery: {
+  type t = Js.t {
+    .
+    lists : Js.t {
+        .
+        nullableOfNullable : option (array (option string)),
+        nullableOfNonNullable : option (array string),
+        nonNullableOfNullable : array (option string),
+        nonNullableOfNonNullable : array string
+      }
+  };
   let make:
     unit =>
     Js.t {
       .
-      parse :
-        Js.Json.t =>
-        Js.t {
-          .
-          lists :
-            Js.t {
-              .
-              nullableOfNullable : option (array (option string)),
-              nullableOfNonNullable : option (array string),
-              nonNullableOfNullable : array (option string),
-              nonNullableOfNonNullable : array string
-            }
-        },
+      parse : Js.Json.t => t,
       query : string,
       variables : Js.Json.t
     };

diff --git a/tests/types/listsArgs.rei b/tests/types/listsArgs.rei
@@ -1,4 +1,5 @@
 module MyQuery: {
+  type t = Js.t {. listsInput : string};
   let make:
     nullableOfNullable::array (option string)? =>
     nullableOfNonNullable::array string? =>
@@ -7,6 +8,6 @@ module MyQuery: {
     unit =>
     Js.t {
       .
-      parse : Js.Json.t => Js.t {. listsInput : string}, query : string, variables : Js.Json.t
+      parse : Js.Json.t => t, query : string, variables : Js.Json.t
     };
 };
diff --git a/tests/types/listsInput.rei b/tests/types/listsInput.rei
@@ -1,4 +1,5 @@
 module MyQuery: {
+  type t = Js.t {. listsInput : string};
   let make:
     arg::
       Js.t {
@@ -11,6 +12,6 @@ module MyQuery: {
     unit =>
     Js.t {
       .
-      parse : Js.Json.t => Js.t {. listsInput : string}, query : string, variables : Js.Json.t
+      parse : Js.Json.t => t, query : string, variables : Js.Json.t
     };
 };
diff --git a/tests/types/mutation.rei b/tests/types/mutation.rei
@@ -1,20 +1,16 @@
 module MyQuery: {
+  type t = Js.t {
+    .
+    mutationWithError : Js.t { .
+      value : option (Js.t {. stringField : string}),
+      errors : option (array (Js.t {. field : [ | `FIRST | `SECOND | `THIRD], message : string}))
+    }
+  };
   let make:
     unit =>
     Js.t {
       .
-      parse :
-        Js.Json.t =>
-        Js.t {
-          .
-          mutationWithError :
-            Js.t {
-              .
-              value : option (Js.t {. stringField : string}),
-              errors :
-                option (array (Js.t {. field : [ | `FIRST | `SECOND | `THIRD], message : string}))
-            }
-        },
+      parse : Js.Json.t => t,
       query : string,
       variables : Js.Json.t
     };

diff --git a/tests/types/nested.rei b/tests/types/nested.rei
@@ -4,17 +4,16 @@ type record = {
 };
 
 module MyQuery: {
+  type t = Js.t {
+    .
+    first : Js.t {. inner : option (Js.t {. inner : option (Js.t {. field : string})})},
+    second : Js.t {. inner : option (Js.t {. inner : option record})}
+  };
   let make:
     unit =>
     Js.t {
       .
-      parse :
-        Js.Json.t =>
-        Js.t {
-          .
-          first : Js.t {. inner : option (Js.t {. inner : option (Js.t {. field : string})})},
-          second : Js.t {. inner : option (Js.t {. inner : option record})}
-        },
+      parse : Js.Json.t => t,
       query : string,
       variables : Js.Json.t
     };

diff --git a/tests/types/record.rei b/tests/types/record.rei
@@ -4,10 +4,11 @@ type scalars = {
 };
 
 module MyQuery: {
+  type t = Js.t {. variousScalars : scalars};
   let make:
     unit =>
     Js.t {
       .
-      parse : Js.Json.t => Js.t {. variousScalars : scalars}, query : string, variables : Js.Json.t
+      parse : Js.Json.t => t, query : string, variables : Js.Json.t
     };
 };
diff --git a/tests/types/scalars.rei b/tests/types/scalars.rei
@@ -1,26 +1,25 @@
 module MyQuery: {
+  type t = Js.t {
+    .
+    variousScalars : Js.t {
+      .
+      nullableString : option string,
+      string: string,
+      nullableInt: option int,
+      int: int,
+      nullableFloat: option float,
+      float: float,
+      nullableBoolean: option Js.boolean,
+      boolean: Js.boolean,
+      nullableID: option string,
+      id: string
+    }
+  };
   let make:
     unit =>
     Js.t {
       .
-      parse :
-        Js.Json.t =>
-        Js.t {
-          .
-          variousScalars : Js.t {
-            .
-            nullableString : option string,
-            string: string,
-            nullableInt: option int,
-            int: int,
-            nullableFloat: option float,
-            float: float,
-            nullableBoolean: option Js.boolean,
-            boolean: Js.boolean,
-            nullableID: option string,
-            id: string
-          }
-        },
+      parse : Js.Json.t => t,
       query : string,
       variables : Js.Json.t
     };

diff --git a/tests/types/scalarsArgs.rei b/tests/types/scalarsArgs.rei
@@ -1,4 +1,5 @@
 module MyQuery: {
+  type t = Js.t {. scalarsInput : string};
   let make:
     nullableString::string? =>
     string::string =>
@@ -13,6 +14,6 @@ module MyQuery: {
     unit =>
     Js.t {
       .
-      parse : Js.Json.t => Js.t {. scalarsInput : string}, query : string, variables : Js.Json.t
+      parse : Js.Json.t => t, query : string, variables : Js.Json.t
     };
 };
diff --git a/tests/types/scalarsInput.rei b/tests/types/scalarsInput.rei
@@ -1,4 +1,5 @@
 module MyQuery: {
+  type t = Js.t {. scalarsInput : string};
   let make:
     arg::
       Js.t {
@@ -17,6 +18,6 @@ module MyQuery: {
     unit =>
     Js.t {
       .
-      parse : Js.Json.t => Js.t {. scalarsInput : string}, query : string, variables : Js.Json.t
+      parse : Js.Json.t => t, query : string, variables : Js.Json.t
     };
 };
diff --git a/tests/types/skipDirectives.rei b/tests/types/skipDirectives.rei
@@ -1,16 +1,15 @@
 module MyQuery: {
+  type t = Js.t {
+    .
+    v1 : Js.t {. nullableString : option string, string : option string},
+    v2 : Js.t {. nullableString : option string, string : option string}
+  };
   let make:
     var::Js.boolean =>
     unit =>
     Js.t {
       .
-      parse :
-        Js.Json.t =>
-        Js.t {
-          .
-          v1 : Js.t {. nullableString : option string, string : option string},
-          v2 : Js.t {. nullableString : option string, string : option string}
-        },
+      parse : Js.Json.t => t,
       query : string,
       variables : Js.Json.t
     };

diff --git a/tests/types/union.re b/tests/types/union.re
@@ -13,4 +13,17 @@ module MyQuery = [%graphql
       }
     }
   |}
-];
+];
+
+module MyNonexhaustiveQuery = [%graphql
+  {|
+    {
+      dogOrHuman {
+        ...on Dog {
+          name
+          barkVolume
+        }
+      }
+    }
+  |}
+];
diff --git a/tests/types/union.rei b/tests/types/union.rei
@@ -1,17 +1,17 @@
 module MyQuery: {
+  type t = Js.t {
+    .
+    dogOrHuman : [
+      | `Dog (Js.t {. name : string, barkVolume : float})
+      | `Human (Js.t {. name : string})
+    ]
+  };
   let make:
     unit =>
     Js.t {
       .
       parse :
-        Js.Json.t =>
-        Js.t {
-          .
-          dogOrHuman : [
-            | `Dog (Js.t {. name : string, barkVolume : float})
-            | `Human (Js.t {. name : string})
-          ]
-        },
+        Js.Json.t => t,
       query : string,
       variables : Js.Json.t
     };

diff --git a/tests/types/unionPartial.rei b/tests/types/unionPartial.rei
@@ -1,14 +1,13 @@
 module MyQuery: {
+  type t = Js.t {
+    .
+    dogOrHuman : [ | `Dog (Js.t {. name : string, barkVolume : float}) | `Nonexhaustive]
+  };
   let make:
     unit =>
     Js.t {
       .
-      parse :
-        Js.Json.t =>
-        Js.t {
-          .
-          dogOrHuman : [ | `Dog (Js.t {. name : string, barkVolume : float}) | `Nonexhaustive]
-        },
+      parse : Js.Json.t => t,
       query : string,
       variables : Js.Json.t
     };

diff --git a/tests/types/variant.rei b/tests/types/variant.rei
@@ -1,17 +1,16 @@
 module MyQuery: {
+  type t = Js.t {
+    .
+    mutationWithError : [
+      | `Value (Js.t {. stringField : string})
+      | `Errors (array (Js.t {. field : [ | `FIRST | `SECOND | `THIRD], message : string}))
+    ]
+  };
   let make:
     unit =>
     Js.t {
       .
-      parse :
-        Js.Json.t =>
-        Js.t {
-          .
-          mutationWithError : [
-            | `Value (Js.t {. stringField : string})
-            | `Errors (array (Js.t {. field : [ | `FIRST | `SECOND | `THIRD], message : string}))
-          ]
-        },
+      parse : Js.Json.t => t,
       query : string,
       variables : Js.Json.t
     };