diff --git a/src/graphql_ppx.ml b/src/graphql_ppx.ml index ebe4e05b..ffec9716 100644 --- 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 index 159987c2..47b2ffcd 100644 --- 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 index 6fb3c385..3a84d7d8 100644 --- 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 index 01a108e7..7831bd46 100644 --- 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 index 6ce9e18a..ea2a195e 100644 --- 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 }; }; \ No newline at end of file diff --git a/tests/types/listsInput.rei b/tests/types/listsInput.rei index 5f7768c0..674508a2 100644 --- 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 }; }; \ No newline at end of file diff --git a/tests/types/mutation.rei b/tests/types/mutation.rei index 29334302..eade5fc7 100644 --- 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 index 2dbec806..12b8f4c6 100644 --- 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 index a35dbb50..32b6103e 100644 --- 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 }; }; \ No newline at end of file diff --git a/tests/types/scalars.rei b/tests/types/scalars.rei index ee3f4477..13c92405 100644 --- 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 index d4529b09..9d09279d 100644 --- 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 }; }; \ No newline at end of file diff --git a/tests/types/scalarsInput.rei b/tests/types/scalarsInput.rei index f6c1acec..b23af14a 100644 --- 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 }; }; \ No newline at end of file diff --git a/tests/types/skipDirectives.rei b/tests/types/skipDirectives.rei index b330da05..8305ad2f 100644 --- 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 index bbd514bc..9b57c19b 100644 --- a/tests/types/union.re +++ b/tests/types/union.re @@ -13,4 +13,17 @@ module MyQuery = [%graphql } } |} -]; \ No newline at end of file +]; + +module MyNonexhaustiveQuery = [%graphql + {| + { + dogOrHuman { + ...on Dog { + name + barkVolume + } + } + } + |} +]; diff --git a/tests/types/union.rei b/tests/types/union.rei index 95b0d9f7..d77ecc70 100644 --- 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 index d18e8968..7a09d7b8 100644 --- 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 index c43a8f07..8507d886 100644 --- 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 };