Skip to content

Commit

Permalink
Increase performance of nested queries
Browse files Browse the repository at this point in the history 
With nested queries the code was switching on the option so that it
could display a custom message. This was causing a massive increase in
compilation time as the queries got deeper and wider. In my project we
were seeing build times of about 6 minutes, after this change the build
went down to about 10-11 seconds.

Instead of displaying a custom message, the PPX will now just call out
to `Js.Option.getExn`.

This might also fix mhallin#61
  • Loading branch information
John Haley committed Jul 12, 2019
1 parent 5796b37 commit 6410c80
Showing 1 changed file with 45 additions and 49 deletions.
94 changes: 45 additions & 49 deletions src/bucklescript/output_bucklescript_decoder.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -42,7 +42,7 @@ let boolean_decoder loc =
let generate_poly_enum_decoder _loc enum_meta =
let enum_match_arms = Ast_helper.(
List.map
(fun {evm_name; _} -> Exp.case
(fun {evm_name; _} -> Exp.case
(Pat.constant (Const_string (evm_name, None)))
(Exp.variant evm_name None))
enum_meta.em_values) in
Expand All @@ -58,7 +58,7 @@ let generate_poly_enum_decoder _loc enum_meta =
(List.map (fun { evm_name; _ } -> Rtag (evm_name, [], true, [])) enum_meta.em_values)
Closed None) [@metaloc loc]
in
[%expr match Js.Json.decodeString value with
[%expr match Js.Json.decodeString value with
| None -> [%e make_error_raiser [%expr
"Expected enum value for " ^
[%e const_str_expr enum_meta.em_name] ^
Expand Down Expand Up @@ -98,9 +98,7 @@ and generate_nullable_decoder config loc inner =
| Some _ -> None] [@metaloc loc]

and generate_array_decoder config loc inner =
[%expr match Js.Json.decodeArray value with
| None -> [%e make_error_raiser [%expr ("Expected array, got " ^ (Js.Json.stringify value))]]
| Some value -> Js.Array.map (fun value -> [%e generate_decoder config inner]) value] [@metaloc loc]
[%expr let value = value |> Js.Json.decodeArray |> Js.Option.getExn in Js.Array.map (fun value -> [%e generate_decoder config inner]) value] [@metaloc loc]

and generate_custom_decoder config loc ident inner =
let fn_expr = Ast_helper.(Exp.ident
Expand Down Expand Up @@ -136,14 +134,14 @@ and generate_record_decoder config loc name fields =
let field_decoder_tuple = Ast_helper.(
fields
|> filter_map (function
| Fr_named_field (field, loc, inner) ->
| Fr_named_field (field, loc, inner) ->
let loc = conv_loc loc in
Some [%expr match Js.Dict.get value [%e const_str_expr field] with
| Some value -> [%e generate_decoder config inner]
| None -> [%e
if can_be_absent_as_field inner then
[%expr None ]
else
else
make_error_raiser [%expr
"Field " ^ [%e const_str_expr field] ^
" on type " ^ [%e const_str_expr name] ^ " is missing"]]] [@metaloc loc]
Expand All @@ -155,7 +153,7 @@ and generate_record_decoder config loc name fields =
|> List.map (function
| Fr_named_field (field, loc, _) ->
let loc = conv_loc loc in
({ Location.loc = loc; txt = Longident.Lident field},
({ Location.loc = loc; txt = Longident.Lident field},
Exp.ident ~loc { loc; txt = Longident.Lident ("field_" ^ field) })
| Fr_fragment_spread (field, loc, name) ->
let loc = conv_loc loc in
Expand All @@ -173,7 +171,7 @@ and generate_record_decoder config loc name fields =
in [%e record]]

and generate_object_decoder config loc name fields =
let ctor_result_type = (List.mapi
let ctor_result_type = (List.mapi
(fun i (Fr_named_field (key, _, _) | Fr_fragment_spread (key, _, _)) -> (key, [], Ast_helper.Typ.var ("a" ^ (string_of_int i))))
fields)
in
Expand All @@ -187,39 +185,37 @@ and generate_object_decoder config loc name fields =
| Fr_fragment_spread (key, _, _) :: next
| Fr_named_field (key, _, _) :: next -> Ast_helper.Typ.arrow key (Ast_helper.Typ.var ("a" ^ (string_of_int i)))
(make_obj_constructor_fn (i+1) next) in
[%expr match Js.Json.decodeObject value with
| None -> [%e make_error_raiser [%expr "Object is not a value"]]
| Some value ->
[%e
Ast_helper.Exp.letmodule {txt = "GQL"; loc = Location.none} (Ast_helper.Mod.structure [
Ast_helper.Str.primitive {
pval_name = {txt = "make_obj"; loc = Location.none};
pval_type = make_obj_constructor_fn 0 fields;
pval_prim = [""];
pval_attributes = [({txt = "bs.obj"; loc = Location.none}, PStr [])];
pval_loc = Location.none;
}
])
(Ast_helper.Exp.apply (Ast_helper.Exp.ident { txt = Longident.parse "GQL.make_obj"; loc = Location.none})
(List.append
(List.map (function
| Fr_named_field (key, _, inner) ->
(key,
[%expr match Js.Dict.get value [%e const_str_expr key] with
| Some value -> [%e generate_decoder config inner]
| None -> [%e
if can_be_absent_as_field inner then
[%expr None]
else
make_error_raiser [%expr "Field " ^ [%e const_str_expr key] ^ " on type " ^ [%e const_str_expr name] ^ " is missing"]
]])
| Fr_fragment_spread (key, loc, name) ->
let loc = conv_loc loc in
(key, [%expr let value = Js.Json.object_ value in [%e generate_solo_fragment_spread loc name]])
) fields)
[("", Ast_helper.Exp.construct { txt = Longident.Lident "()"; loc = Location.none} None)]
))
]
[%expr let value = value |> Js.Json.decodeObject |> Js.Option.getExn in
[%e
Ast_helper.Exp.letmodule {txt = "GQL"; loc = Location.none} (Ast_helper.Mod.structure [
Ast_helper.Str.primitive {
pval_name = {txt = "make_obj"; loc = Location.none};
pval_type = make_obj_constructor_fn 0 fields;
pval_prim = [""];
pval_attributes = [({txt = "bs.obj"; loc = Location.none}, PStr [])];
pval_loc = Location.none;
}
])
(Ast_helper.Exp.apply (Ast_helper.Exp.ident { txt = Longident.parse "GQL.make_obj"; loc = Location.none})
(List.append
(List.map (function
| Fr_named_field (key, _, inner) ->
(key,
[%expr match Js.Dict.get value [%e const_str_expr key] with
| Some value -> [%e generate_decoder config inner]
| None -> [%e
if can_be_absent_as_field inner then
[%expr None]
else
make_error_raiser [%expr "Field " ^ [%e const_str_expr key] ^ " on type " ^ [%e const_str_expr name] ^ " is missing"]
]])
| Fr_fragment_spread (key, loc, name) ->
let loc = conv_loc loc in
(key, [%expr let value = Js.Json.object_ value in [%e generate_solo_fragment_spread loc name]])
) fields)
[("", Ast_helper.Exp.construct { txt = Longident.Lident "()"; loc = Location.none} None)]
))
]
] [@metaloc loc]

and generate_poly_variant_selection_set config loc name fields =
Expand All @@ -236,7 +232,7 @@ and generate_poly_variant_selection_set config loc name fields =
| None -> let value = temp in [%e variant_decoder]
| Some _ -> [%e generator_loop next]]
| [] -> make_error_raiser [%expr
"All fields on variant selection set on type " ^
"All fields on variant selection set on type " ^
[%e const_str_expr name] ^
" were null"] in
let variant_type = Ast_helper.(
Expand All @@ -258,14 +254,14 @@ and generate_poly_variant_interface config loc name base fragments =
let name_pattern = Pat.constant (Const_string (type_name, None)) in
let variant = Exp.variant type_name (Some (generate_decoder config inner)) in
Exp.case name_pattern variant
) in
) in
let map_case_ty (name, _) =
Rtag (name, [], false, [{ ptyp_desc = Ptyp_any; ptyp_attributes = []; ptyp_loc = Location.none }])
in

let fragment_cases = List.map map_case fragments in
let fallback_case = map_fallback_case base in
let fallback_case_ty = map_case_ty base in
let fallback_case_ty = map_case_ty base in

let fragment_case_tys = List.map map_case_ty fragments in
let interface_ty = Ast_helper.(Typ.variant (fallback_case_ty :: fragment_case_tys) Closed None) in
Expand All @@ -285,11 +281,11 @@ and generate_poly_variant_interface config loc name base fragments =
"Interface implementation " ^ [%e const_str_expr name] ^
" has a __typename field that is not a string"]]
| Some typename -> ([%e typename_matcher]: [%t interface_ty])] [@metaloc loc]

and generate_poly_variant_union config loc name fragments exhaustive_flag =
let fragment_cases = Ast_helper.(
fragments
|> List.map (fun (type_name, inner) ->
|> List.map (fun (type_name, inner) ->
let name_pattern = Pat.constant (Const_string (type_name, None)) in
let variant = Ast_helper.(Exp.variant type_name (Some (generate_decoder config inner))) in
Exp.case name_pattern variant)) in
Expand All @@ -301,10 +297,10 @@ and generate_poly_variant_union config loc name fragments exhaustive_flag =
"Union " ^ [%e const_str_expr name] ^
" returned unknown type " ^ typename]),
[ ])
| Nonexhaustive ->
| Nonexhaustive ->
(Exp.case (Pat.any ()) [%expr `Nonexhaustive]), [Rtag ("Nonexhaustive", [], true, [])]) in
let fragment_case_tys = List.map
(fun (name, _) -> Rtag (name, [], false, [{ ptyp_desc = Ptyp_any; ptyp_attributes = []; ptyp_loc = Location.none }]))
(fun (name, _) -> Rtag (name, [], false, [{ ptyp_desc = Ptyp_any; ptyp_attributes = []; ptyp_loc = Location.none }]))
fragments in
let union_ty = Ast_helper.(Typ.variant (List.concat [ fallback_case_ty; fragment_case_tys ]) Closed None) in
let typename_matcher = Ast_helper.(Exp.match_
Expand Down

0 comments on commit 6410c80

Please sign in to comment.