Skip to content

Commit 3ecf863

Browse files
bobzhangbobzhang
committed
refactor to make use of polyvar as string to simplify FFI
1 parent f18185a commit 3ecf863

File tree

7 files changed

+89
-47
lines changed

7 files changed

+89
-47
lines changed

‎jscomp/core/js_of_lam_variant.ml

Lines changed: 38 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -31,39 +31,59 @@ type arg_expression =
3131
| Splice2 of E.t * E.t
3232

3333
(* we need destruct [undefined] when input is optional *)
34-
let eval (arg : J.expression) (dispatches : (Ast_compatible.hash_label * string) list ) : E.t =
34+
let eval (arg : J.expression) (dispatches : (Ast_compatible.hash_label * string) list option) : E.t =
3535
if arg == E.undefined then E.undefined else
3636
match arg.expression_desc with
37-
| Str (_,s) ->
38-
E.str (Ext_list.assoc_by_string dispatches s None)
39-
| _ ->
40-
E.of_block
41-
[(S.string_switch arg
42-
(Ext_list.map dispatches (fun (i,r) ->
43-
{J.switch_case = i ;
44-
switch_body = [S.return_stmt (E.str r)];
45-
should_break = false; (* FIXME: if true, still print break*)
46-
comment = None;
47-
})))]
37+
| Str (_,s) ->
38+
let s = match dispatches with
39+
| None -> s
40+
| Some dispatches ->
41+
(Ext_list.assoc_by_string dispatches s None) in
42+
E.str s
43+
| _ ->
44+
match dispatches with
45+
| None ->
46+
E.poly_var_tag_access arg
47+
| Some dispatches ->
48+
E.of_block
49+
[(S.string_switch arg
50+
(Ext_list.map dispatches (fun (i,r) ->
51+
{J.switch_case = i ;
52+
switch_body = [S.return_stmt (E.str r)];
53+
should_break = false; (* FIXME: if true, still print break*)
54+
comment = None;
55+
})))]
4856

4957
(** invariant: optional is not allowed in this case *)
5058
(** arg is a polyvar *)
51-
let eval_as_event (arg : J.expression) (dispatches : (Ast_compatible.hash_label * string) list ) =
59+
let eval_as_event (arg : J.expression) (dispatches : (Ast_compatible.hash_label * string) list option) =
5260
match arg.expression_desc with
5361
| Caml_block([{expression_desc = Str(_,s)}; cb], _, _, Blk_poly_var ) when Js_analyzer.no_side_effect_expression cb
5462
->
55-
let v = Ext_list.assoc_by_string dispatches s None in
63+
let v =
64+
match dispatches with
65+
| Some dispatches ->
66+
Ext_list.assoc_by_string dispatches s None
67+
| None -> s in
5668
Splice2(E.str v , cb )
5769
| _ ->
5870
Splice2
59-
(E.of_block
60-
[(S.string_switch (E.poly_var_tag_access arg)
61-
(Ext_list.map dispatches (fun (i,r) ->
71+
(
72+
(match dispatches with
73+
| Some dispatches ->
74+
E.of_block
75+
[
76+
77+
(S.string_switch (E.poly_var_tag_access arg)
78+
(Ext_list.map dispatches (fun (i,r) ->
6279
{J.switch_case = i ;
6380
switch_body = [S.return_stmt (E.str r)];
6481
should_break = false; (* FIXME: if true, still print break*)
6582
comment = None;
66-
}) ))]
83+
}) ))
84+
85+
]
86+
| None -> E.poly_var_tag_access arg )
6787
, (* TODO: improve, one dispatch later,
6888
the problem is that we can not create bindings
6989
due to the

‎jscomp/core/js_of_lam_variant.mli

Lines changed: 12 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -30,9 +30,18 @@ type arg_expression =
3030
| Splice2 of J.expression * J.expression
3131

3232
val eval :
33-
J.expression -> (Ast_compatible.hash_label * string) list -> J.expression
33+
J.expression ->
34+
(Ast_compatible.hash_label * string) list option
35+
-> J.expression
36+
3437
val eval_as_event :
35-
J.expression -> (Ast_compatible.hash_label * string) list -> arg_expression
38+
J.expression ->
39+
(Ast_compatible.hash_label * string) list option
40+
-> arg_expression
41+
3642
val eval_as_int :
37-
J.expression -> (Ast_compatible.hash_label * int) list -> J.expression
43+
J.expression ->
44+
(Ast_compatible.hash_label * int) list ->
45+
J.expression
46+
3847
val eval_as_unwrap : J.expression -> J.expression

‎jscomp/core/lam_compile_external_call.ml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -118,9 +118,9 @@ let ocaml_to_js_eff
118118
[]
119119
else
120120
[arg])
121-
| NullString dispatches ->
121+
| Poly_var {has_payload = false ; descr = dispatches} ->
122122
Splice1 (Js_of_lam_variant.eval arg dispatches),[]
123-
| NonNullString dispatches ->
123+
| Poly_var {has_payload = true ; descr = dispatches} ->
124124
Js_of_lam_variant.eval_as_event arg dispatches,[]
125125
(* FIXME: encode invariant below in the signature*)
126126
(* length of 2

‎jscomp/syntax/ast_external_process.ml

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -440,7 +440,7 @@ let process_obj
440440
{obj_arg_label = External_arg_spec.obj_label s; obj_arg_type},
441441
{param_type with ty = new_ty}::arg_types,
442442
(({Asttypes.txt = name; loc}, [], Ast_literal.type_int ~loc ()) :: result_types)
443-
| NullString _ ->
443+
| Poly_var { has_payload = false ; _} ->
444444
let s = Lam_methname.translate name in
445445
{obj_arg_label = External_arg_spec.obj_label s; obj_arg_type},
446446
{param_type with ty = new_ty }::arg_types,
@@ -449,7 +449,7 @@ let process_obj
449449
Location.raise_errorf ~loc
450450
"The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
451451
| Extern_unit -> assert false
452-
| NonNullString _
452+
| Poly_var { has_payload = true ; _}
453453
->
454454
Location.raise_errorf ~loc
455455
"bs.obj label %s does not support such arg type" name
@@ -473,7 +473,7 @@ let process_obj
473473
{obj_arg_label = External_arg_spec.optional s ; obj_arg_type },
474474
param_type :: arg_types,
475475
(({Asttypes.txt = name; loc}, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_int ~loc ()) :: result_types)
476-
| NullString _ ->
476+
| Poly_var {has_payload = false ; _} ->
477477
let s = Lam_methname.translate name in
478478
{obj_arg_label = External_arg_spec.optional s ; obj_arg_type },
479479
param_type::arg_types,
@@ -485,7 +485,7 @@ let process_obj
485485
Location.raise_errorf ~loc
486486
"The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
487487
| Extern_unit -> assert false
488-
| NonNullString _
488+
| Poly_var {has_payload = true; _}
489489
->
490490
Location.raise_errorf ~loc
491491
"bs.obj label %s does not support such arg type" name
@@ -899,7 +899,7 @@ let handle_attributes
899899
| Optional s ->
900900
let arg_type = get_opt_arg_type ~nolabel:false ty in
901901
begin match arg_type with
902-
| NonNullString _ ->
902+
| Poly_var {has_payload = true; _} ->
903903
(* ?x:([`x of int ] [@bs.string]) does not make sense *)
904904
Location.raise_errorf
905905
~loc

‎jscomp/syntax/ast_polyvar.ml

Lines changed: 15 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -84,35 +84,36 @@ let map_constructor_declarations_into_ints
8484
*)
8585
let map_row_fields_into_strings ptyp_loc
8686
(row_fields : Parsetree.row_field list) : External_arg_spec.attr =
87+
let has_bs_as = ref false in
8788
let case, result =
8889
Ext_list.fold_right row_fields (`Nothing, []) (fun tag (nullary, acc) ->
8990
match nullary, tag with
9091
| (`Nothing | `Null),
9192
Rtag (label, attrs, true, [])
9293
->
93-
begin match Ast_attributes.iter_process_bs_string_as attrs with
94+
let name =
95+
match Ast_attributes.iter_process_bs_string_as attrs with
9496
| Some name ->
95-
`Null, ((Ast_compatible.hash_label label, name) :: acc )
96-
97-
| None ->
98-
`Null, ((Ast_compatible.hash_label label, Ast_compatible.label_of_name label) :: acc )
99-
end
97+
has_bs_as := true; name
98+
| None -> label.txt
99+
in `Null, (label.txt, name) :: acc
100100
| (`Nothing | `NonNull), Rtag(label, attrs, false, ([ _ ]))
101101
->
102-
begin match Ast_attributes.iter_process_bs_string_as attrs with
102+
let name =
103+
match Ast_attributes.iter_process_bs_string_as attrs with
103104
| Some name ->
104-
`NonNull, ((Ast_compatible.hash_label label, name) :: acc)
105-
| None ->
106-
`NonNull, ((Ast_compatible.hash_label label, Ast_compatible.label_of_name label) :: acc)
107-
end
105+
has_bs_as := true; name
106+
| None -> label.txt
107+
in `NonNull, (label.txt, name) :: acc
108108
| _ -> Bs_syntaxerr.err ptyp_loc Invalid_bs_string_type
109109

110110
) in
111111
match case with
112112
| `Nothing -> Bs_syntaxerr.err ptyp_loc Invalid_bs_string_type
113-
| `Null -> External_arg_spec.NullString result
114-
| `NonNull -> NonNullString result
115-
113+
| `Null
114+
| `NonNull ->
115+
External_arg_spec.Poly_var {has_payload = case = `NonNull ;
116+
descr = if !has_bs_as then Some result else None }
116117

117118
let is_enum row_fields =
118119
List.for_all (fun (x : Parsetree.row_field) ->

‎jscomp/syntax/external_arg_spec.ml

Lines changed: 9 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -45,9 +45,16 @@ type label =
4545
| Obj_optional of {name : string }
4646
(* it will be ignored , side effect will be recorded *)
4747

48+
49+
4850
type attr =
49-
| NullString of (Ast_compatible.hash_label * string) list (* `a does not have any value*)
50-
| NonNullString of (Ast_compatible.hash_label * string) list (* `a of int *)
51+
| Poly_var of {
52+
has_payload : bool ;
53+
descr :
54+
(Ast_compatible.hash_label * string) list
55+
option
56+
}
57+
(* `a does not have any value*)
5158
| Int of (Ast_compatible.hash_label * int ) list (* ([`a | `b ] [@bs.int])*)
5259
| Arg_cst of cst
5360
| Fn_uncurry_arity of int (* annotated with [@bs.uncurry ] or [@bs.uncurry 2]*)

‎jscomp/syntax/external_arg_spec.mli

Lines changed: 8 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -33,15 +33,20 @@ type cst = private
3333

3434
type label = private
3535
| Obj_label of {name : string}
36-
(* | Obj_labelCst of {name : string ; cst : cst} *)
3736
| Obj_empty
3837

3938
| Obj_optional of {name : string}
4039
(* it will be ignored , side effect will be recorded *)
4140

41+
42+
4243
type attr =
43-
| NullString of (Ast_compatible.hash_label * string) list (* `a does not have any value*)
44-
| NonNullString of (Ast_compatible.hash_label * string) list (* `a of int *)
44+
| Poly_var of {
45+
has_payload : bool ;
46+
descr :
47+
(Ast_compatible.hash_label * string)
48+
list option
49+
}
4550
| Int of (Ast_compatible.hash_label * int ) list (* ([`a | `b ] [@bs.int])*)
4651
| Arg_cst of cst
4752
| Fn_uncurry_arity of int (* annotated with [@bs.uncurry ] or [@bs.uncurry 2]*)

0 commit comments

Comments
 (0)