Skip to content

fix #666 see test/module_as_class_ffi #667

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 2 commits into from
Aug 23, 2016
Merged

fix #666 see test/module_as_class_ffi #667

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
a8e77d4
implement gpr#666 see test/module_as_class_ffi
Aug 23, 2016
cdc162a
more todo notes
Aug 23, 2016
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
102 changes: 89 additions & 13 deletions jscomp/bin/bs_ppx.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
(** Bundled by bspack 08/22-17:28 *)
(** Bundled by bspack 08/23-11:37 *)
module String_map : sig
#1 "string_map.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
Expand Down Expand Up @@ -4034,7 +4034,7 @@ let int32 = "Caml_int32"
let block = "Block"
let js_primitive = "Js_primitive"
let module_ = "Caml_module"
let version = "0.9.4"
let version = "0.9.5"


let runtime_set =
Expand Down Expand Up @@ -4240,7 +4240,8 @@ type ffi =
| Obj_create of arg_label list
| Js_global of js_val
| Js_module_as_var of external_module_name
| Js_module_as_fn of external_module_name
| Js_module_as_fn of external_module_name
| Js_module_as_class of external_module_name
| Js_call of js_call external_module
| Js_send of js_send
| Js_new of js_val
Expand Down Expand Up @@ -4340,7 +4341,8 @@ type ffi =
| Obj_create of arg_label list
| Js_global of js_val
| Js_module_as_var of external_module_name
| Js_module_as_fn of external_module_name
| Js_module_as_fn of external_module_name
| Js_module_as_class of external_module_name
| Js_call of js_call external_module
| Js_send of js_send
| Js_new of js_val
Expand Down Expand Up @@ -4416,7 +4418,8 @@ let check_ffi ?loc ffi =
-> ()

| Js_module_as_var external_module_name
| Js_module_as_fn external_module_name
| Js_module_as_fn external_module_name
| Js_module_as_class external_module_name
-> check_external_module_name external_module_name
| Js_new {external_module_name ; txt = name}
| Js_call {external_module_name ; txt = {name ; _}}
Expand Down Expand Up @@ -4579,7 +4582,19 @@ let handle_attributes
let result_type = aux result_type_ty in
let ffi =
match st with
| {mk_obj = true} ->
| {mk_obj = true;

val_name = None;
external_module_name = None ;
module_as_val = None;
val_send = None;
splice = false;
new_name = None;
call_name = None;
set_name = None ;
get_name = None ;
get_index = false ;
} ->
let labels = List.map (function
| {arg_type = Unit ; arg_label = (Empty as l)}
-> l
Expand All @@ -4592,7 +4607,24 @@ let handle_attributes
if String.length prim_name <> 0 then
Location.raise_errorf ~loc "[@@bs.obj] expect external names to be empty string";
Obj_create labels(* Need fetch label here, for better error message *)
| {set_index = true}
| {mk_obj = true; _}
->
Location.raise_errorf ~loc "conflict attributes found"
| {set_index = true;

val_name = None;
external_module_name = None ;
module_as_val = None;
val_send = None;
splice = false;
get_index = false;
new_name = None;
call_name = None;
set_name = None ;
get_name = None ;
mk_obj = false ;

}
->
if String.length prim_name <> 0 then
Location.raise_errorf ~loc "[@@bs.set_index] expect external names to be empty string";
Expand All @@ -4602,19 +4634,63 @@ let handle_attributes
Js_set_index
| _ -> Location.raise_errorf ~loc "Ill defined attribute [@@bs.set_index](arity of 3)"
end
| {get_index = true} ->
| {set_index = true; _}
->
Location.raise_errorf ~loc "conflict attributes found"

| {get_index = true;

val_name = None;
external_module_name = None ;
module_as_val = None;
val_send = None;
splice = false;
new_name = None;
call_name = None;
set_name = None ;
get_name = None ;
mk_obj = false ;
} ->
if String.length prim_name <> 0 then
Location.raise_errorf ~loc "[@@bs.get_index] expect external names to be empty string";
begin match arg_types with
| [_obj; _v ] ->
Js_get_index
| _ -> Location.raise_errorf ~loc "Ill defined attribute [@@bs.get_index] (arity of 2)"
end
| {module_as_val = Some v } ->
begin match arg_types_ty with
| [] -> Js_module_as_var v
| _ -> Js_module_as_fn v
end
| {get_index = true; _}
-> Location.raise_errorf ~loc "conflict attributes found"
| {module_as_val = Some v ;

get_index = false;
val_name ;
new_name ;
(*TODO: a better way to avoid breaking existing code,
we need tell the difference from
{[
1. [@@bs.val "x"]
2. external x : .. "x" [@@bs.val ]
3. external x : .. "" [@@bs.val]
]}
*)
external_module_name = None ;
val_send = None;
splice = false;
call_name = None;
set_name = None ;
get_name = None ;
mk_obj = false ;
} ->
begin match arg_types_ty, new_name, val_name with
| [], None, _ -> Js_module_as_var v
| _, None, _ -> Js_module_as_fn v
| _, Some _, Some _ ->
Location.raise_errorf ~loc "conflict attributes found"
| _, Some n, None
-> Js_module_as_class v
end
| {module_as_val = Some _}
-> Location.raise_errorf ~loc "conflict attributes found"
| {call_name = Some name ;
splice;
external_module_name;
Expand Down
138 changes: 117 additions & 21 deletions jscomp/bin/compiler.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
(** Bundled by bspack 08/22-17:28 *)
(** Bundled by bspack 08/23-11:37 *)
module String_map : sig
#1 "string_map.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
Expand Down Expand Up @@ -4034,7 +4034,7 @@ let int32 = "Caml_int32"
let block = "Block"
let js_primitive = "Js_primitive"
let module_ = "Caml_module"
let version = "0.9.4"
let version = "0.9.5"


let runtime_set =
Expand Down Expand Up @@ -4240,7 +4240,8 @@ type ffi =
| Obj_create of arg_label list
| Js_global of js_val
| Js_module_as_var of external_module_name
| Js_module_as_fn of external_module_name
| Js_module_as_fn of external_module_name
| Js_module_as_class of external_module_name
| Js_call of js_call external_module
| Js_send of js_send
| Js_new of js_val
Expand Down Expand Up @@ -4340,7 +4341,8 @@ type ffi =
| Obj_create of arg_label list
| Js_global of js_val
| Js_module_as_var of external_module_name
| Js_module_as_fn of external_module_name
| Js_module_as_fn of external_module_name
| Js_module_as_class of external_module_name
| Js_call of js_call external_module
| Js_send of js_send
| Js_new of js_val
Expand Down Expand Up @@ -4416,7 +4418,8 @@ let check_ffi ?loc ffi =
-> ()

| Js_module_as_var external_module_name
| Js_module_as_fn external_module_name
| Js_module_as_fn external_module_name
| Js_module_as_class external_module_name
-> check_external_module_name external_module_name
| Js_new {external_module_name ; txt = name}
| Js_call {external_module_name ; txt = {name ; _}}
Expand Down Expand Up @@ -4579,7 +4582,19 @@ let handle_attributes
let result_type = aux result_type_ty in
let ffi =
match st with
| {mk_obj = true} ->
| {mk_obj = true;

val_name = None;
external_module_name = None ;
module_as_val = None;
val_send = None;
splice = false;
new_name = None;
call_name = None;
set_name = None ;
get_name = None ;
get_index = false ;
} ->
let labels = List.map (function
| {arg_type = Unit ; arg_label = (Empty as l)}
-> l
Expand All @@ -4592,7 +4607,24 @@ let handle_attributes
if String.length prim_name <> 0 then
Location.raise_errorf ~loc "[@@bs.obj] expect external names to be empty string";
Obj_create labels(* Need fetch label here, for better error message *)
| {set_index = true}
| {mk_obj = true; _}
->
Location.raise_errorf ~loc "conflict attributes found"
| {set_index = true;

val_name = None;
external_module_name = None ;
module_as_val = None;
val_send = None;
splice = false;
get_index = false;
new_name = None;
call_name = None;
set_name = None ;
get_name = None ;
mk_obj = false ;

}
->
if String.length prim_name <> 0 then
Location.raise_errorf ~loc "[@@bs.set_index] expect external names to be empty string";
Expand All @@ -4602,19 +4634,63 @@ let handle_attributes
Js_set_index
| _ -> Location.raise_errorf ~loc "Ill defined attribute [@@bs.set_index](arity of 3)"
end
| {get_index = true} ->
| {set_index = true; _}
->
Location.raise_errorf ~loc "conflict attributes found"

| {get_index = true;

val_name = None;
external_module_name = None ;
module_as_val = None;
val_send = None;
splice = false;
new_name = None;
call_name = None;
set_name = None ;
get_name = None ;
mk_obj = false ;
} ->
if String.length prim_name <> 0 then
Location.raise_errorf ~loc "[@@bs.get_index] expect external names to be empty string";
begin match arg_types with
| [_obj; _v ] ->
Js_get_index
| _ -> Location.raise_errorf ~loc "Ill defined attribute [@@bs.get_index] (arity of 2)"
end
| {module_as_val = Some v } ->
begin match arg_types_ty with
| [] -> Js_module_as_var v
| _ -> Js_module_as_fn v
end
| {get_index = true; _}
-> Location.raise_errorf ~loc "conflict attributes found"
| {module_as_val = Some v ;

get_index = false;
val_name ;
new_name ;
(*TODO: a better way to avoid breaking existing code,
we need tell the difference from
{[
1. [@@bs.val "x"]
2. external x : .. "x" [@@bs.val ]
3. external x : .. "" [@@bs.val]
]}
*)
external_module_name = None ;
val_send = None;
splice = false;
call_name = None;
set_name = None ;
get_name = None ;
mk_obj = false ;
} ->
begin match arg_types_ty, new_name, val_name with
| [], None, _ -> Js_module_as_var v
| _, None, _ -> Js_module_as_fn v
| _, Some _, Some _ ->
Location.raise_errorf ~loc "conflict attributes found"
| _, Some n, None
-> Js_module_as_class v
end
| {module_as_val = Some _}
-> Location.raise_errorf ~loc "conflict attributes found"
| {call_name = Some name ;
splice;
external_module_name;
Expand Down Expand Up @@ -25782,6 +25858,25 @@ let translate_ffi (ffi : Ast_external_attributes.ffi ) prim_name
| _ ->
E.call ~info:{arity=Full; call_info = Call_na} fn args
end
| Js_module_as_class module_name ->
let fn =
match handle_external (Some module_name) with
| Some (id,name) ->
E.external_var_dot id name None
| None -> assert false in
let args =
Ext_list.flat_map2_last (ocaml_to_js false) arg_types args
(* TODO: fix in rest calling convention *)
in
begin
(match cxt.st with
| Declare (_, id) | Assign id ->
(* Format.fprintf Format.err_formatter "%a@."Ident.print id; *)
Ext_ident.make_js_object id
| EffectCall | NeedValue -> ())
;
E.new_ fn args
end

| Js_new { external_module_name = module_name;
txt = fn;
Expand All @@ -25808,14 +25903,15 @@ let translate_ffi (ffi : Ast_external_attributes.ffi ) prim_name
TODO: we should propagate this property
as much as we can(in alias table)
*)
(
match cxt.st with
| Declare (_, id) | Assign id ->
(* Format.fprintf Format.err_formatter "%a@."Ident.print id; *)
Ext_ident.make_js_object id
| EffectCall | NeedValue -> ()
);
E.new_ fn args
begin
(match cxt.st with
| Declare (_, id) | Assign id ->
(* Format.fprintf Format.err_formatter "%a@."Ident.print id; *)
Ext_ident.make_js_object id
| EffectCall | NeedValue -> ())
;
E.new_ fn args
end



Expand Down
2 changes: 1 addition & 1 deletion jscomp/common/js_config.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -248,7 +248,7 @@ let int32 = "Caml_int32"
let block = "Block"
let js_primitive = "Js_primitive"
let module_ = "Caml_module"
let version = "0.9.4"
let version = "0.9.5"


let runtime_set =
Expand Down
Loading