diff --git a/jscomp/Makefile b/jscomp/Makefile index 0198fbf49a..0efa16d0ae 100644 --- a/jscomp/Makefile +++ b/jscomp/Makefile @@ -143,7 +143,9 @@ OUNIT_TESTS_SRCS = ounit_tests_util \ ounit_sexp_tests\ ounit_int_vec_tests\ ounit_ident_mask_tests\ + ounit_cmd_util\ ounit_cmd_tests\ + ounit_ffi_error_debug_test\ ounit_tests_main OUNIT_TESTS_CMXS = $(addprefix ounit_tests/, $(addsuffix .cmx, $(OUNIT_TESTS_SRCS))) diff --git a/jscomp/all.depend b/jscomp/all.depend index 782a76a391..6987200c87 100644 --- a/jscomp/all.depend +++ b/jscomp/all.depend @@ -181,9 +181,9 @@ syntax/ast_ffi_types.cmx : ext/ext_string.cmx ext/ext_pervasives.cmx \ common/bs_version.cmx syntax/ast_core_type.cmx syntax/ast_ffi_types.cmi syntax/ast_external_attributes.cmx : common/lam_methname.cmx \ ext/ext_string.cmx ext/ext_pervasives.cmx common/bs_warnings.cmx \ - common/bs_loc.cmx syntax/ast_payload.cmx syntax/ast_ffi_types.cmx \ - syntax/ast_core_type.cmx syntax/ast_comb.cmx syntax/ast_attributes.cmx \ - syntax/ast_external_attributes.cmi + common/bs_loc.cmx syntax/ast_payload.cmx syntax/ast_literal.cmx \ + syntax/ast_ffi_types.cmx syntax/ast_core_type.cmx syntax/ast_comb.cmx \ + syntax/ast_attributes.cmx syntax/ast_external_attributes.cmi syntax/ast_util.cmx : ext/literals.cmx ext/ext_list.cmx \ syntax/ast_payload.cmx syntax/ast_pat.cmx syntax/ast_literal.cmx \ syntax/ast_external_attributes.cmx syntax/ast_external.cmx \ @@ -582,6 +582,7 @@ ounit/oUnitLogger.cmx : ounit/oUnitUtils.cmx ounit/oUnitTypes.cmx ounit/oUnitTypes.cmx : ounit/oUnitUtils.cmx : ounit/oUnitTypes.cmx ounit/oUnitChooser.cmx : ounit/oUnitTypes.cmx +ounit_tests/ounit_cmd_util.cmi : ounit_tests/ounit_tests_main.cmi : ounit_tests/ounit_tests_util.cmx : ounit_tests/ounit_array_tests.cmx : ounit/oUnit.cmx ext/ext_string.cmx \ @@ -616,8 +617,12 @@ ounit_tests/ounit_int_vec_tests.cmx : ounit/oUnit.cmx ext/int_vec_util.cmx \ ext/int_vec.cmx ounit_tests/ounit_ident_mask_tests.cmx : ounit/oUnit.cmx \ ext/hash_set_ident_mask.cmx -ounit_tests/ounit_cmd_tests.cmx : ounit/oUnit.cmx ext/literals.cmx \ - ext/ext_string.cmx +ounit_tests/ounit_cmd_util.cmx : ext/literals.cmx \ + ounit_tests/ounit_cmd_util.cmi +ounit_tests/ounit_cmd_tests.cmx : ounit_tests/ounit_cmd_util.cmx \ + ounit/oUnit.cmx ext/literals.cmx ext/ext_string.cmx +ounit_tests/ounit_ffi_error_debug_test.cmx : ounit_tests/ounit_cmd_util.cmx \ + ounit/oUnit.cmx ext/ext_string.cmx ounit_tests/ounit_tests_main.cmx : ext/resize_array.cmx \ ounit_tests/ounit_vec_test.cmx ounit_tests/ounit_union_find_tests.cmx \ ounit_tests/ounit_topsort_tests.cmx ounit_tests/ounit_string_tests.cmx \ @@ -628,9 +633,11 @@ ounit_tests/ounit_tests_main.cmx : ext/resize_array.cmx \ ounit_tests/ounit_json_tests.cmx ounit_tests/ounit_int_vec_tests.cmx \ ounit_tests/ounit_ident_mask_tests.cmx \ ounit_tests/ounit_hashtbl_tests.cmx ounit_tests/ounit_hash_stubs_test.cmx \ - ounit_tests/ounit_hash_set_tests.cmx ounit_tests/ounit_cmd_tests.cmx \ - ounit_tests/ounit_bal_tree_tests.cmx ounit_tests/ounit_array_tests.cmx \ - ounit/oUnit.cmx ounit_tests/ounit_tests_main.cmi + ounit_tests/ounit_hash_set_tests.cmx \ + ounit_tests/ounit_ffi_error_debug_test.cmx \ + ounit_tests/ounit_cmd_tests.cmx ounit_tests/ounit_bal_tree_tests.cmx \ + ounit_tests/ounit_array_tests.cmx ounit/oUnit.cmx \ + ounit_tests/ounit_tests_main.cmi bsb/bsb_build_schemas.cmx : bsb/bsb_build_ui.cmx : ext/string_vec.cmx ext/string_set.cmx \ ext/string_map.cmx ext/ext_string.cmx ext/ext_json.cmx \ diff --git a/jscomp/bin/all_ounit_tests.d b/jscomp/bin/all_ounit_tests.d index db3346fcc6..4fec1ea794 100644 --- a/jscomp/bin/all_ounit_tests.d +++ b/jscomp/bin/all_ounit_tests.d @@ -22,7 +22,10 @@ bin/all_ounit_tests.ml : ext/set_poly.mli bin/all_ounit_tests.ml : ounit_tests/ounit_bal_tree_tests.ml bin/all_ounit_tests.ml : ext/literals.ml bin/all_ounit_tests.ml : ext/literals.mli +bin/all_ounit_tests.ml : ounit_tests/ounit_cmd_util.ml +bin/all_ounit_tests.ml : ounit_tests/ounit_cmd_util.mli bin/all_ounit_tests.ml : ounit_tests/ounit_cmd_tests.ml +bin/all_ounit_tests.ml : ounit_tests/ounit_ffi_error_debug_test.ml bin/all_ounit_tests.ml : ext/ext_util.ml bin/all_ounit_tests.ml : ext/ext_util.mli bin/all_ounit_tests.ml : ext/hash_set_gen.ml diff --git a/jscomp/bin/all_ounit_tests.i.ml b/jscomp/bin/all_ounit_tests.i.ml index 955b7faa8f..79a37450d2 100644 --- a/jscomp/bin/all_ounit_tests.i.ml +++ b/jscomp/bin/all_ounit_tests.i.ml @@ -75,7 +75,7 @@ open OUnitTypes (** Most simple heuristic, just pick the first test. *) let simple state = - (* 116 *) List.hd state.tests_planned + (* 119 *) List.hd state.tests_planned end module OUnitUtils @@ -98,22 +98,22 @@ let is_success = let is_failure = function | RFailure _ -> (* 0 *) true - | RSuccess _ | RError _ | RSkip _ | RTodo _ -> (* 232 *) false + | RSuccess _ | RError _ | RSkip _ | RTodo _ -> (* 238 *) false let is_error = function | RError _ -> (* 0 *) true - | RSuccess _ | RFailure _ | RSkip _ | RTodo _ -> (* 232 *) false + | RSuccess _ | RFailure _ | RSkip _ | RTodo _ -> (* 238 *) false let is_skip = function | RSkip _ -> (* 0 *) true - | RSuccess _ | RFailure _ | RError _ | RTodo _ -> (* 232 *) false + | RSuccess _ | RFailure _ | RError _ | RTodo _ -> (* 238 *) false let is_todo = function | RTodo _ -> (* 0 *) true - | RSuccess _ | RFailure _ | RError _ | RSkip _ -> (* 232 *) false + | RSuccess _ | RFailure _ | RError _ | RSkip _ -> (* 238 *) false let result_flavour = function @@ -145,7 +145,7 @@ let rec was_successful = | [] -> (* 3 *) true | RSuccess _::t | RSkip _::t -> - (* 348 *) was_successful t + (* 357 *) was_successful t | RFailure _::_ | RError _::_ @@ -155,22 +155,22 @@ let rec was_successful = let string_of_node = function | ListItem n -> - (* 464 *) string_of_int n + (* 476 *) string_of_int n | Label s -> - (* 696 *) s + (* 714 *) s (* Return the number of available tests *) let rec test_case_count = function - | TestCase _ -> (* 116 *) 1 - | TestLabel (_, t) -> (* 136 *) test_case_count t + | TestCase _ -> (* 119 *) 1 + | TestLabel (_, t) -> (* 140 *) test_case_count t | TestList l -> - (* 20 *) List.fold_left - (fun c t -> (* 135 *) c + test_case_count t) + (* 21 *) List.fold_left + (fun c t -> (* 139 *) c + test_case_count t) 0 l let string_of_path path = - (* 232 *) String.concat ":" (List.rev_map string_of_node path) + (* 238 *) String.concat ":" (List.rev_map string_of_node path) let buff_format_printf f = (* 0 *) let buff = Buffer.create 13 in @@ -193,13 +193,13 @@ let mapi f l = rmapi 0 l let fold_lefti f accu l = - (* 20 *) let rec rfold_lefti cnt accup l = - (* 155 *) match l with + (* 21 *) let rec rfold_lefti cnt accup l = + (* 160 *) match l with | [] -> - (* 20 *) accup + (* 21 *) accup | h::t -> - (* 135 *) rfold_lefti (cnt + 1) (f accup h cnt) t + (* 139 *) rfold_lefti (cnt + 1) (f accup h cnt) t in rfold_lefti 0 accu l @@ -217,7 +217,7 @@ open OUnitUtils type event_type = GlobalEvent of global_event | TestEvent of test_event let format_event verbose event_type = - (* 698 *) match event_type with + (* 716 *) match event_type with | GlobalEvent e -> (* 2 *) begin match e with @@ -276,31 +276,31 @@ let format_event verbose event_type = end | TestEvent e -> - (* 696 *) begin + (* 714 *) begin let string_of_result = if verbose then - (* 348 *) function - | RSuccess _ -> (* 116 *) "ok\n" + (* 357 *) function + | RSuccess _ -> (* 119 *) "ok\n" | RFailure (_, _) -> (* 0 *) "FAIL\n" | RError (_, _) -> (* 0 *) "ERROR\n" | RSkip (_, _) -> (* 0 *) "SKIP\n" | RTodo (_, _) -> (* 0 *) "TODO\n" else - (* 348 *) function - | RSuccess _ -> (* 116 *) "." + (* 357 *) function + | RSuccess _ -> (* 119 *) "." | RFailure (_, _) -> (* 0 *) "F" | RError (_, _) -> (* 0 *) "E" | RSkip (_, _) -> (* 0 *) "S" | RTodo (_, _) -> (* 0 *) "T" in if verbose then - (* 348 *) match e with + (* 357 *) match e with | EStart p -> - (* 116 *) Printf.sprintf "%s start\n" (string_of_path p) + (* 119 *) Printf.sprintf "%s start\n" (string_of_path p) | EEnd p -> - (* 116 *) Printf.sprintf "%s end\n" (string_of_path p) + (* 119 *) Printf.sprintf "%s end\n" (string_of_path p) | EResult result -> - (* 116 *) string_of_result result + (* 119 *) string_of_result result | ELog (lvl, str) -> (* 0 *) let prefix = match lvl with @@ -312,21 +312,21 @@ let format_event verbose event_type = | ELogRaw str -> (* 0 *) str else - (* 348 *) match e with - | EStart _ | EEnd _ | ELog _ | ELogRaw _ -> (* 232 *) "" - | EResult result -> (* 116 *) string_of_result result + (* 357 *) match e with + | EStart _ | EEnd _ | ELog _ | ELogRaw _ -> (* 238 *) "" + | EResult result -> (* 119 *) string_of_result result end let file_logger fn = (* 1 *) let chn = open_out fn in (fun ev -> - (* 349 *) output_string chn (format_event true ev); + (* 358 *) output_string chn (format_event true ev); flush chn), (fun () -> (* 1 *) close_out chn) let std_logger verbose = (* 1 *) (fun ev -> - (* 349 *) print_string (format_event verbose ev); + (* 358 *) print_string (format_event verbose ev); flush stdout), (fun () -> (* 1 *) ()) @@ -343,7 +343,7 @@ let create output_file_opt verbose (log,close) = (* 0 *) null_logger in (fun ev -> - (* 349 *) std_log ev; file_log ev; log ev), + (* 358 *) std_log ev; file_log ev; log ev), (fun () -> (* 1 *) std_close (); file_close (); close ()) @@ -705,7 +705,7 @@ let assert_failure msg = (* 0 *) failwith ("OUnit: " ^ msg) let assert_bool msg b = - (* 2005360 *) if not b then (* 0 *) assert_failure msg + (* 2005363 *) if not b then (* 0 *) assert_failure msg let assert_string str = (* 0 *) if not (str = "") then (* 0 *) assert_failure str @@ -951,8 +951,8 @@ let (@?) = assert_bool (* Some shorthands which allows easy test construction *) let (>:) s t = (* 0 *) TestLabel(s, t) (* infix *) -let (>::) s f = (* 116 *) TestLabel(s, TestCase(f)) (* infix *) -let (>:::) s l = (* 20 *) TestLabel(s, TestList(l)) (* infix *) +let (>::) s f = (* 119 *) TestLabel(s, TestCase(f)) (* infix *) +let (>:::) s l = (* 21 *) TestLabel(s, TestList(l)) (* infix *) (* Utility function to manipulate test *) let rec test_decorate g = @@ -1087,7 +1087,7 @@ let maybe_backtrace = "" (* Run all tests, report starts, errors, failures, and return the results *) let perform_test report test = (* 1 *) let run_test_case f path = - (* 116 *) try + (* 119 *) try f (); RSuccess path with @@ -1106,22 +1106,22 @@ let perform_test report test = let rec flatten_test path acc = function | TestCase(f) -> - (* 116 *) (path, f) :: acc + (* 119 *) (path, f) :: acc | TestList (tests) -> - (* 20 *) fold_lefti + (* 21 *) fold_lefti (fun acc t cnt -> - (* 135 *) flatten_test + (* 139 *) flatten_test ((ListItem cnt)::path) acc t) acc tests | TestLabel (label, t) -> - (* 136 *) flatten_test ((Label label)::path) acc t + (* 140 *) flatten_test ((Label label)::path) acc t in let test_cases = List.rev (flatten_test [] [] test) in let runner (path, f) = - (* 116 *) let result = + (* 119 *) let result = report (EStart path); run_test_case f path in @@ -1130,18 +1130,18 @@ let perform_test report test = result in let rec iter state = - (* 117 *) match state.tests_planned with + (* 120 *) match state.tests_planned with | [] -> (* 1 *) state.results | _ -> - (* 116 *) let (path, f) = !global_chooser state in + (* 119 *) let (path, f) = !global_chooser state in let result = runner (path, f) in iter { results = result :: state.results; tests_planned = List.filter - (fun (path', _) -> (* 6786 *) path <> path') state.tests_planned + (fun (path', _) -> (* 7140 *) path <> path') state.tests_planned } in iter {results = []; tests_planned = test_cases} @@ -1171,7 +1171,7 @@ let run_test_tt ?verbose test = time_fun perform_test (fun ev -> - (* 348 *) log (OUnitLogger.TestEvent ev)) + (* 357 *) log (OUnitLogger.TestEvent ev)) test in @@ -1894,11 +1894,11 @@ let equal (x : string) y = (* 0 *) x = y let unsafe_is_sub ~sub i s j ~len = - (* 523 *) let rec check k = - (* 655 *) if k = len - then (* 31 *) true + (* 681 *) let rec check k = + (* 864 *) if k = len + then (* 34 *) true else - (* 624 *) String.unsafe_get sub (i+k) = + (* 830 *) String.unsafe_get sub (i+k) = String.unsafe_get s (j+k) && check (k+1) in j+len <= String.length s && check 0 @@ -1906,21 +1906,21 @@ let unsafe_is_sub ~sub i s j ~len = exception Local_exit let find ?(start=0) ~sub s = - (* 37 *) let n = String.length sub in + (* 40 *) let n = String.length sub in let s_len = String.length s in let i = ref start in try while !i + n <= s_len do - (* 515 *) if unsafe_is_sub ~sub 0 s !i ~len:n then - (* 29 *) raise_notrace Local_exit; + (* 673 *) if unsafe_is_sub ~sub 0 s !i ~len:n then + (* 32 *) raise_notrace Local_exit; incr i done; -1 with Local_exit -> - (* 29 *) !i + (* 32 *) !i let contain_substring s sub = - (* 7 *) find s ~sub >= 0 + (* 10 *) find s ~sub >= 0 (** TODO: optimize avoid nonterminating when string is empty @@ -3481,9 +3481,26 @@ let goog = "goog" let unused_attribute = "Unused attribute " end -module Ounit_cmd_tests -= struct -#1 "ounit_cmd_tests.ml" +module Ounit_cmd_util : sig +#1 "ounit_cmd_util.mli" +type output = { + stderr : string ; + stdout : string ; + exit_code : int +} + + +val perform : string -> string array -> output + + +val perform_bsc : string array -> output + + +val bsc_eval : string -> output + +val debug_output : output -> unit +end = struct +#1 "ounit_cmd_util.ml" let (//) = Filename.concat (** may nonterminate when [cwd] is '.' *) @@ -3500,14 +3517,6 @@ let runtime_dir = jscomp // "runtime" let others_dir = jscomp // "others" let stdlib_dir = jscomp // "stdlib" - -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let (=~) = OUnit.assert_equal - - - let rec safe_dup fd = (* 0 *) let new_fd = Unix.dup fd in if (Obj.magic new_fd : int) >= 3 then @@ -3519,7 +3528,7 @@ let rec safe_dup fd = end let safe_close fd = - (* 14 *) try Unix.close fd with Unix.Unix_error(_,_,_) -> (* 0 *) () + (* 20 *) try Unix.close fd with Unix.Unix_error(_,_,_) -> (* 0 *) () type output = { @@ -3529,7 +3538,7 @@ type output = { } let perform command args = - (* 7 *) let new_fd_in, new_fd_out = Unix.pipe () in + (* 10 *) let new_fd_in, new_fd_out = Unix.pipe () in let err_fd_in, err_fd_out = Unix.pipe () in match Unix.fork () with | 0 -> @@ -3548,7 +3557,7 @@ let perform command args = when all the descriptiors on a pipe's output are closed, a call to [write] on its input kills the writing process (EPIPE). *) - (* 7 *) safe_close new_fd_out ; + (* 10 *) safe_close new_fd_out ; safe_close err_fd_out ; let in_chan = Unix.in_channel_of_descr new_fd_in in let err_in_chan = Unix.in_channel_of_descr err_fd_in in @@ -3556,20 +3565,20 @@ let perform command args = let err_buf = Buffer.create 1024 in (try while true do - (* 65 *) Buffer.add_string buf (input_line in_chan ); + (* 68 *) Buffer.add_string buf (input_line in_chan ); Buffer.add_char buf '\n' done; with - End_of_file -> (* 7 *) ()) ; + End_of_file -> (* 10 *) ()) ; (try while true do - (* 100 *) Buffer.add_string err_buf (input_line err_in_chan ); + (* 109 *) Buffer.add_string err_buf (input_line err_in_chan ); Buffer.add_char err_buf '\n' done; with - End_of_file -> (* 7 *) ()) ; + End_of_file -> (* 10 *) ()) ; let exit_code = match snd @@ Unix.waitpid [] pid with - | Unix.WEXITED exit_code -> (* 7 *) exit_code + | Unix.WEXITED exit_code -> (* 10 *) exit_code | Unix.WSIGNALED _signal_number | Unix.WSTOPPED _signal_number -> (* 0 *) 127 in { @@ -3580,7 +3589,7 @@ let perform command args = let perform_bsc args = - (* 7 *) perform bsc_exe + (* 10 *) perform bsc_exe (Array.append [|bsc_exe ; "-bs-package-name" ; "bs-platform"; @@ -3597,16 +3606,35 @@ let perform_bsc args = |] args) let bsc_eval str = - (* 4 *) perform_bsc [|"-bs-eval"; str|] + (* 7 *) perform_bsc [|"-bs-eval"; str|] + + let debug_output o = + (* 0 *) Printf.printf "\nexit_code:%d\nstdout:%s\nstderr:%s\n" + o.exit_code o.stdout o.stderr + +end +module Ounit_cmd_tests += struct +#1 "ounit_cmd_tests.ml" +let (//) = Filename.concat + + + + +let ((>::), + (>:::)) = OUnit.((>::),(>:::)) + +let (=~) = OUnit.assert_equal + + + + (* let output_of_exec_command command args = let readme, writeme = Unix.pipe () in let pid = Unix.create_process command args Unix.stdin writeme Unix.stderr in let in_chan = Unix.in_channel_of_descr readme *) -let debug_output o = - (* 0 *) Printf.printf "\nexit_code:%d\nstdout:%s\nstderr:%s\n" - o.exit_code o.stdout o.stderr let react = {| type u @@ -3633,6 +3661,9 @@ let d = bar () |} +let perform_bsc = Ounit_cmd_util.perform_bsc +let bsc_eval = Ounit_cmd_util.bsc_eval + let suites = __FILE__ @@ -3681,6 +3712,62 @@ let suites = ] +end +module Ounit_ffi_error_debug_test += struct +#1 "ounit_ffi_error_debug_test.ml" +let (//) = Filename.concat + + + + +let ((>::), + (>:::)) = OUnit.((>::),(>:::)) + +let (=~) = OUnit.assert_equal + + + + +let bsc_eval = Ounit_cmd_util.bsc_eval + +let debug_output = Ounit_cmd_util.debug_output + + +let suites = + __FILE__ + >::: [ + __LOC__ >:: begin fun _ -> + (* 1 *) let output = bsc_eval {| +external err : + hi_should_error:([`a of int | `b of string ] [@bs.string]) -> + unit -> _ = "" [@@bs.obj] + |} in + OUnit.assert_bool __LOC__ + (Ext_string.contain_substring output.stderr "hi_should_error") + end; + __LOC__ >:: begin fun _ -> +(* 1 *) let output = bsc_eval {| + external err : + ?hi_should_error:([`a of int | `b of string ] [@bs.string]) -> + unit -> _ = "" [@@bs.obj] + |} in + OUnit.assert_bool __LOC__ + (Ext_string.contain_substring output.stderr "hi_should_error") + end; + __LOC__ >:: begin fun _ -> + (* 1 *) let output = bsc_eval {| + external err : + ?hi_should_error:([`a of int | `b of string ] [@bs.string]) -> + unit -> unit = "" [@@bs.val] + |} in + OUnit.assert_bool __LOC__ + (Ext_string.contain_substring output.stderr "hi_should_error") + end + + + + ] end module Ext_util : sig #1 "ext_util.mli" @@ -13024,7 +13111,8 @@ let suites = Ounit_sexp_tests.suites; Ounit_int_vec_tests.suites; Ounit_ident_mask_tests.suites; - Ounit_cmd_tests.suites + Ounit_cmd_tests.suites; + Ounit_ffi_error_debug_test.suites; ] let _ = OUnit.run_test_tt_main suites diff --git a/jscomp/bin/all_ounit_tests.ml b/jscomp/bin/all_ounit_tests.ml index 566bee3c71..2a600c8d81 100644 --- a/jscomp/bin/all_ounit_tests.ml +++ b/jscomp/bin/all_ounit_tests.ml @@ -3481,9 +3481,26 @@ let goog = "goog" let unused_attribute = "Unused attribute " end -module Ounit_cmd_tests -= struct -#1 "ounit_cmd_tests.ml" +module Ounit_cmd_util : sig +#1 "ounit_cmd_util.mli" +type output = { + stderr : string ; + stdout : string ; + exit_code : int +} + + +val perform : string -> string array -> output + + +val perform_bsc : string array -> output + + +val bsc_eval : string -> output + +val debug_output : output -> unit +end = struct +#1 "ounit_cmd_util.ml" let (//) = Filename.concat (** may nonterminate when [cwd] is '.' *) @@ -3500,14 +3517,6 @@ let runtime_dir = jscomp // "runtime" let others_dir = jscomp // "others" let stdlib_dir = jscomp // "stdlib" - -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let (=~) = OUnit.assert_equal - - - let rec safe_dup fd = let new_fd = Unix.dup fd in if (Obj.magic new_fd : int) >= 3 then @@ -3599,14 +3608,33 @@ let perform_bsc args = let bsc_eval str = perform_bsc [|"-bs-eval"; str|] + let debug_output o = + Printf.printf "\nexit_code:%d\nstdout:%s\nstderr:%s\n" + o.exit_code o.stdout o.stderr + +end +module Ounit_cmd_tests += struct +#1 "ounit_cmd_tests.ml" +let (//) = Filename.concat + + + + +let ((>::), + (>:::)) = OUnit.((>::),(>:::)) + +let (=~) = OUnit.assert_equal + + + + + (* let output_of_exec_command command args = let readme, writeme = Unix.pipe () in let pid = Unix.create_process command args Unix.stdin writeme Unix.stderr in let in_chan = Unix.in_channel_of_descr readme *) -let debug_output o = - Printf.printf "\nexit_code:%d\nstdout:%s\nstderr:%s\n" - o.exit_code o.stdout o.stderr let react = {| type u @@ -3633,6 +3661,9 @@ let d = bar () |} +let perform_bsc = Ounit_cmd_util.perform_bsc +let bsc_eval = Ounit_cmd_util.bsc_eval + let suites = __FILE__ @@ -3681,6 +3712,62 @@ let suites = ] +end +module Ounit_ffi_error_debug_test += struct +#1 "ounit_ffi_error_debug_test.ml" +let (//) = Filename.concat + + + + +let ((>::), + (>:::)) = OUnit.((>::),(>:::)) + +let (=~) = OUnit.assert_equal + + + + +let bsc_eval = Ounit_cmd_util.bsc_eval + +let debug_output = Ounit_cmd_util.debug_output + + +let suites = + __FILE__ + >::: [ + __LOC__ >:: begin fun _ -> + let output = bsc_eval {| +external err : + hi_should_error:([`a of int | `b of string ] [@bs.string]) -> + unit -> _ = "" [@@bs.obj] + |} in + OUnit.assert_bool __LOC__ + (Ext_string.contain_substring output.stderr "hi_should_error") + end; + __LOC__ >:: begin fun _ -> +let output = bsc_eval {| + external err : + ?hi_should_error:([`a of int | `b of string ] [@bs.string]) -> + unit -> _ = "" [@@bs.obj] + |} in + OUnit.assert_bool __LOC__ + (Ext_string.contain_substring output.stderr "hi_should_error") + end; + __LOC__ >:: begin fun _ -> + let output = bsc_eval {| + external err : + ?hi_should_error:([`a of int | `b of string ] [@bs.string]) -> + unit -> unit = "" [@@bs.val] + |} in + OUnit.assert_bool __LOC__ + (Ext_string.contain_substring output.stderr "hi_should_error") + end + + + + ] end module Ext_util : sig #1 "ext_util.mli" @@ -13024,7 +13111,8 @@ let suites = Ounit_sexp_tests.suites; Ounit_int_vec_tests.suites; Ounit_ident_mask_tests.suites; - Ounit_cmd_tests.suites + Ounit_cmd_tests.suites; + Ounit_ffi_error_debug_test.suites; ] let _ = OUnit.run_test_tt_main suites diff --git a/jscomp/bin/bsdep.ml b/jscomp/bin/bsdep.ml index d2ed593af2..802ecfefe8 100644 --- a/jscomp/bin/bsdep.ml +++ b/jscomp/bin/bsdep.ml @@ -23987,6 +23987,7 @@ module Lid : sig type t = Longident.t val val_unit : t val type_unit : t + val type_int : t val js_fn : t val js_meth : t val js_meth_callback : t @@ -24009,7 +24010,7 @@ val val_unit : expression_lit val type_unit : core_type_lit val type_string : core_type_lit - +val type_int : core_type_lit val type_any : core_type_lit val pat_unit : pattern_lit @@ -24048,6 +24049,7 @@ module Lid = struct let val_unit : t = Lident "()" let type_unit : t = Lident "unit" let type_string : t = Lident "string" + let type_int : t = Lident "int" (* use *predef* *) (* TODO should be renamed in to {!Js.fn} *) (* TODO should be moved into {!Js.t} Later *) let js_fn = Longident.Ldot (Lident "Js", "fn") @@ -24068,7 +24070,8 @@ module No_loc = struct Ast_helper.Exp.construct {txt = Lid.val_unit; loc } None let type_unit = Ast_helper.Typ.mk (Ptyp_constr ({ txt = Lid.type_unit; loc}, [])) - + let type_int = + Ast_helper.Typ.mk (Ptyp_constr ({txt = Lid.type_int; loc}, [])) let type_string = Ast_helper.Typ.mk (Ptyp_constr ({ txt = Lid.type_string; loc}, [])) @@ -24101,6 +24104,12 @@ let type_string ?loc () = | Some loc -> Ast_helper.Typ.mk ~loc (Ptyp_constr ({ txt = Lid.type_string; loc}, [])) +let type_int ?loc () = + match loc with + | None -> No_loc.type_int + | Some loc -> + Ast_helper.Typ.mk ~loc (Ptyp_constr ({ txt = Lid.type_int; loc}, [])) + let type_any ?loc () = match loc with | None -> No_loc.type_any @@ -25824,6 +25833,8 @@ type t = Parsetree.core_type val extract_option_type_exn : t -> t +val lift_option_type : t -> t +val is_any : t -> bool val replace_result : t -> t -> t val is_unit : t -> bool @@ -25837,7 +25848,7 @@ type arg_type = | NonNullString of (int * string) list | Int of (int * int ) list | Array - | Unit + | Extern_unit | Nothing | Ignore @@ -25864,6 +25875,7 @@ val make_obj : (string * Parsetree.attributes * t) list -> t +val is_optional_label : string -> bool end = struct #1 "ast_core_type.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. @@ -25897,11 +25909,11 @@ type arg_label = | Empty (* it will be ignored , side effect will be recorded *) type arg_type = - | NullString of (int * string) list - | NonNullString of (int * string) list + | NullString of (int * string) list (* `a does not have any value*) + | NonNullString of (int * string) list (* `a of int *) | Int of (int * int ) list | Array - | Unit + | Extern_unit | Nothing | Ignore @@ -25917,7 +25929,23 @@ let extract_option_type_exn (ty : t) = | _ -> assert false end - +let predef_option : Longident.t = Longident.Ldot (Lident "*predef*", "option") +let predef_int : Longident.t = Ldot (Lident "*predef*", "int") + + +let lift_option_type (ty:t) : t = + {ptyp_desc = + Ptyp_constr( + {txt = predef_option; + loc = ty.ptyp_loc} + , [ty]); + ptyp_loc = ty.ptyp_loc; + ptyp_attributes = [] + } + +let is_any (ty : t) = + match ty with {ptyp_desc = Ptyp_any} -> true | _ -> false + open Ast_helper let replace_result ty result = @@ -25941,12 +25969,12 @@ let is_array (ty : t) = | Ptyp_constr({txt =Lident "array"}, [_]) -> true | _ -> false -let is_optional l = +let is_optional_label l = String.length l > 0 && l.[0] = '?' let label_name l : arg_label = if l = "" then Empty else - if is_optional l + if is_optional_label l then Optional (String.sub l 1 (String.length l - 1)) else Label l @@ -26278,9 +26306,10 @@ type arg_kind = arg_label : arg_label } +type obj_create = arg_kind list type ffi = - | Obj_create of arg_label list + (* | Obj_create of obj_create*) | Js_global of js_global_val | Js_module_as_var of external_module_name | Js_module_as_fn of js_module_as_fn @@ -26295,6 +26324,7 @@ type ffi = type t = | Ffi_bs of arg_kind list * bool * ffi + | Ffi_obj_create of obj_create | Ffi_normal (* When it's normal, it is handled as normal c functional ffi call *) @@ -26378,10 +26408,10 @@ type arg_kind = arg_type : arg_type; arg_label : arg_label } - +type obj_create = arg_kind list type ffi = - | Obj_create of arg_label list + (* | Obj_create of obj_create *) | Js_global of js_global_val | Js_module_as_var of external_module_name | Js_module_as_fn of js_module_as_fn @@ -26412,14 +26442,15 @@ let name_of_ffi ffi = | Js_global v -> Printf.sprintf "[@@bs.val] %S " v.name - | Obj_create _ -> - Printf.sprintf "[@@bs.obj]" + (* | Obj_create _ -> + Printf.sprintf "[@@bs.obj]" *) type t = | Ffi_bs of arg_kind list * bool * ffi (** [Ffi_bs(args,return,ffi) ] [return] means return value is unit or not, [true] means is [unit] *) + | Ffi_obj_create of obj_create | Ffi_normal (* When it's normal, it is handled as normal c functional ffi call *) @@ -26485,7 +26516,7 @@ let check_ffi ?loc ffi = | Js_set name | Js_get name -> valid_method_name ?loc name - | Obj_create _ -> () + (* | Obj_create _ -> () *) | Js_get_index | Js_set_index -> () @@ -27739,10 +27770,11 @@ end = struct ]} The result type would be [ hi:string ] *) -let get_arg_type - ({ptyp_desc; ptyp_attributes; ptyp_loc = loc} as ptyp : Ast_core_type.t) : +let get_arg_type ~nolabel optional + (ptyp : Ast_core_type.t) : Ast_core_type.arg_type * Ast_core_type.t = - match Ast_attributes.process_bs_string_int ptyp_attributes, ptyp_desc with + let ptyp = if optional then Ast_core_type.extract_option_type_exn ptyp else ptyp in + match Ast_attributes.process_bs_string_int ptyp.ptyp_attributes, ptyp.ptyp_desc with | (`String, ptyp_attributes), Ptyp_variant ( row_fields, Closed, None) -> let case, result, row_fields = @@ -27770,16 +27802,16 @@ let get_arg_type `NonNull, ((Ext_pervasives.hash_variant label, label) :: acc), (tag :: row_fields) end - | _ -> Location.raise_errorf ~loc "Not a valid string type" + | _ -> Location.raise_errorf ~loc:ptyp.ptyp_loc "Not a valid string type" ) row_fields (`Nothing, [], [])) in (match case with - | `Nothing -> Location.raise_errorf ~loc "Not a valid string type" + | `Nothing -> Location.raise_errorf ~loc:ptyp.ptyp_loc "Not a valid string type" | `Null -> NullString result | `NonNull -> NonNullString result) , {ptyp with ptyp_desc = Ptyp_variant(row_fields, Closed, None); ptyp_attributes ; } - | (`String, _), _ -> Location.raise_errorf ~loc "Not a valid string type" + | (`String, _), _ -> Location.raise_errorf ~loc:ptyp.ptyp_loc "Not a valid string type" | (`Ignore, ptyp_attributes), _ -> (Ignore, {ptyp with ptyp_attributes}) @@ -27798,7 +27830,7 @@ let get_arg_type i + 1 , ((Ext_pervasives.hash_variant label , i):: acc ), rtag::row_fields end - | _ -> Location.raise_errorf ~loc "Not a valid string type" + | _ -> Location.raise_errorf ~loc:ptyp.ptyp_loc "Not a valid string type" ) (0, [],[]) row_fields) in Int (List.rev acc), {ptyp with @@ -27806,19 +27838,19 @@ let get_arg_type ptyp_attributes } - | (`Int, _), _ -> Location.raise_errorf ~loc "Not a valid string type" + | (`Int, _), _ -> Location.raise_errorf ~loc:ptyp.ptyp_loc "Not a valid string type" | (`Nothing, ptyp_attributes), ptyp_desc -> begin match ptyp_desc with | Ptyp_constr ({txt = Lident "bool"}, []) -> - Bs_warnings.prerr_warning loc Unsafe_ffi_bool_type; + Bs_warnings.prerr_warning ptyp.ptyp_loc Unsafe_ffi_bool_type; Nothing | Ptyp_constr ({txt = Lident "unit"}, []) - -> Unit + -> if nolabel then Extern_unit else Nothing | Ptyp_constr ({txt = Lident "array"}, [_]) -> Array | Ptyp_variant _ -> - Bs_warnings.prerr_warning loc Unsafe_poly_variant_type; + Bs_warnings.prerr_warning ptyp.ptyp_loc Unsafe_poly_variant_type; Nothing | _ -> Nothing @@ -27954,7 +27986,7 @@ let process_external_attributes (init_st, []) prim_attributes -let list_of_arrow_clean_option_label (ty : Parsetree.core_type) = +let list_of_arrow (ty : Parsetree.core_type) = let rec aux (ty : Parsetree.core_type) acc = match ty.ptyp_desc with | Ptyp_arrow(label,t1,t2) -> @@ -27964,6 +27996,7 @@ let list_of_arrow_clean_option_label (ty : Parsetree.core_type) = | return_type -> ty, List.rev acc in aux ty [] + (** Note that the passed [type_annotation] is already processed by visitor pattern before *) let handle_attributes @@ -27977,43 +28010,18 @@ let handle_attributes else `Nm_external prim_name (* need check name *) in let result_type, arg_types_ty = - list_of_arrow_clean_option_label type_annotation in + list_of_arrow type_annotation in let result_type_spec, new_result_type = - get_arg_type result_type in + get_arg_type ~nolabel:true false result_type in (* result type can not be labeled *) let (st, left_attrs) = process_external_attributes (arg_types_ty = []) prim_name_or_pval_prim pval_prim prim_attributes in - let splice = st.splice in - let arg_type_specs, new_arg_types_ty, arg_type_specs_length = - List.fold_right - (fun (label,ty,attr,loc) (arg_type_specs, arg_types, i) -> - let arg_type, new_ty = get_arg_type ty in - (if i = 0 && splice then - match arg_type with - | Array -> () - | _ -> Location.raise_errorf ~loc "[@@bs.splice] expect last type to array"); - ({ Ast_ffi_types.arg_label = Ast_core_type.label_name label ; - arg_type - } :: arg_type_specs, - (label, new_ty,attr,loc) :: arg_types, - i + 1) - ) arg_types_ty - (match st with - | {val_send_pipe = Some obj} -> - let arg_type, new_ty = get_arg_type obj in - [{ arg_label = Empty ; - arg_type - }], - ["", new_ty, [], obj.ptyp_loc] - ,0 - | {val_send_pipe = None } -> [],[], 0) in - - - let ffi = - match st with - | { mk_obj = true; + + if st.mk_obj then + begin match st with + | { val_name = `Nm_na; external_module_name = None ; module_as_val = None; @@ -28025,314 +28033,385 @@ let handle_attributes set_name = `Nm_na ; get_name = `Nm_na ; get_index = false ; - } -> - if String.length prim_name <> 0 then - Location.raise_errorf ~loc "[@@bs.obj] expect external names to be empty string"; - Ast_ffi_types.Obj_create (List.map (function - | {Ast_ffi_types.arg_label = (Empty as l) ; arg_type = Unit } - -> l - | {arg_label = Empty ; arg_type = _ } - -> Location.raise_errorf ~loc "expect label, optional, or unit here" - | {arg_label = (Label _) ; arg_type = (Ignore | Unit) ; } - -> Empty - | {arg_label = Label name ; arg_type = (Nothing | Array)} -> - Label (Lam_methname.translate ~loc name) - | {arg_label = Label l ; arg_type = (NullString _ | NonNullString _ | Int _ ) } - -> Location.raise_errorf ~loc - "bs.obj label %s does not support such arg type" l - | {arg_label = Optional name ; arg_type = (Nothing | Array | Unit | Ignore)} - -> Optional (Lam_methname.translate ~loc name) - | {arg_label = Optional l ; arg_type = (NullString _ | NonNullString _ | Int _)} - -> Location.raise_errorf ~loc - "bs.obj optional %s does not support such arg type" l ) - arg_type_specs)(* Need fetch label here, for better error message *) - | {mk_obj = true; _} - -> - Location.raise_errorf ~loc "conflict attributes found" - | {set_index = true; - - val_name = `Nm_na; - external_module_name = None ; - module_as_val = None; - val_send = `Nm_na; - val_send_pipe = None; - splice = false; - get_index = false; - new_name = `Nm_na; - call_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - mk_obj = false ; - - } - -> - if String.length prim_name <> 0 then - Location.raise_errorf ~loc "[@@bs.set_index] expect external names to be empty string"; - if arg_type_specs_length = 3 then - Js_set_index - else - Location.raise_errorf ~loc "Ill defined attribute [@@bs.set_index](arity of 3)" + } -> + if String.length prim_name <> 0 then + Location.raise_errorf ~loc "[@@bs.obj] expect external names to be empty string"; + let arg_kinds, new_arg_types_ty, result_types = + List.fold_right + (fun (label,ty,attr,loc) ( arg_labels, arg_types, result_types) -> + let arg_label = Ast_core_type.label_name label in + let new_arg_label, new_ty, output_tys = + match arg_label with + | Empty -> + let arg_type, new_ty = get_arg_type ~nolabel:true false ty in + begin match arg_type with + | Extern_unit -> { Ast_ffi_types. arg_label; arg_type }, new_ty, result_types + | _ -> + Location.raise_errorf ~loc "expect label, optional, or unit here" + end + | Label name -> + let arg_type, new_ty = get_arg_type ~nolabel:false false ty in + begin match arg_type with + | Ignore -> { arg_label = Empty ; arg_type }, new_ty, result_types + + | Nothing | Array -> + let s = (Lam_methname.translate ~loc name) in + {arg_label = Label s ; arg_type }, new_ty, + ((name , [], new_ty) :: result_types) + | Int _ -> + let s = Lam_methname.translate ~loc name in + {arg_label = Label s; arg_type}, new_ty, ((name, [], Ast_literal.type_int ~loc ()) :: result_types) + | NullString _ -> + let s = Lam_methname.translate ~loc name in + {arg_label = Label s; arg_type}, new_ty, + ((name, [], Ast_literal.type_string ~loc ()) :: result_types) + | Extern_unit -> assert false + | NonNullString _ + -> + Location.raise_errorf ~loc + "bs.obj label %s does not support such arg type" name + end + | Optional name -> + let arg_type, new_ty_extract = get_arg_type ~nolabel:false true ty in + let new_ty = Ast_core_type.lift_option_type new_ty_extract in + begin match arg_type with + | Ignore -> + {arg_label = Empty ; arg_type}, new_ty, result_types + + | Nothing | Array -> + let s = (Lam_methname.translate ~loc name) in + {arg_label = Optional s; arg_type}, new_ty, + ( (name, [], Ast_comb.to_undefined_type loc new_ty_extract) :: result_types) + | Int _ -> + let s = Lam_methname.translate ~loc name in + {arg_label = Optional s ; arg_type }, new_ty, + ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_int ~loc ()) :: result_types) + | NullString _ -> + let s = Lam_methname.translate ~loc name in + {arg_label = Optional s ; arg_type }, new_ty, + ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_string ~loc ()) :: result_types) + | Extern_unit -> assert false + | NonNullString _ + -> + Location.raise_errorf ~loc + "bs.obj label %s does not support such arg type" name + end + in + ( + new_arg_label::arg_labels, + (label, new_ty,attr,loc) :: arg_types, + output_tys)) arg_types_ty + ( [], [], []) in + let result = + if Ast_core_type.is_any new_result_type then + Ast_core_type.make_obj ~loc result_types + else new_result_type + in + begin + ( + List.fold_right (fun (label,ty,attrs,loc) acc -> + Ast_helper.Typ.arrow ~loc ~attrs label ty acc + ) new_arg_types_ty result + ) , + prim_name, + Ffi_obj_create arg_kinds, + left_attrs + end - | {set_index = true; _} - -> - Location.raise_errorf ~loc "conflict attributes found" - - | {get_index = true; - - val_name = `Nm_na; - external_module_name = None ; - module_as_val = None; - val_send = `Nm_na; - val_send_pipe = None; - - splice = false; - new_name = `Nm_na; - call_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - mk_obj = false ; - } -> - if String.length prim_name <> 0 then - Location.raise_errorf ~loc "[@@bs.get_index] expect external names to be empty string"; - if arg_type_specs_length = 2 then - Js_get_index - else Location.raise_errorf ~loc "Ill defined attribute [@@bs.get_index] (arity of 2)" - - | {get_index = true; _} - -> Location.raise_errorf ~loc "conflict attributes found" - - - (*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] ]} - *) - | {module_as_val = Some external_module_name ; - - get_index = false; - val_name ; - new_name ; - - external_module_name = None ; - val_send = `Nm_na; - val_send_pipe = None; - splice ; - call_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - mk_obj = false ;} -> - begin match arg_types_ty, new_name, val_name with - | [], `Nm_na, _ -> Js_module_as_var external_module_name - | _, `Nm_na, _ -> Js_module_as_fn {splice; external_module_name } - | _, #bundle_source, #bundle_source -> - Location.raise_errorf ~loc "conflict attributes found" - | _, (`Nm_val _ | `Nm_external _) , `Nm_na - -> Js_module_as_class external_module_name - | _, `Nm_payload _ , `Nm_na - -> - Location.raise_errorf ~loc - "conflict attributes found: (bs.new should not carry payload here)" + | _ -> Location.raise_errorf ~loc "conflict attributes found [@@bs.obj]" - end - | {module_as_val = Some _} - -> Location.raise_errorf ~loc "conflict attributes found" - | {call_name = (`Nm_val name | `Nm_external name | `Nm_payload name) ; - splice; - external_module_name; - - val_name = `Nm_na ; - module_as_val = None; - val_send = `Nm_na ; - val_send_pipe = None; - - set_index = false; - get_index = false; - new_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na - } -> - Js_call {splice; name; external_module_name} - | {call_name = #bundle_source } - -> Location.raise_errorf ~loc "conflict attributes found" - - | {val_name = (`Nm_val name | `Nm_external name | `Nm_payload name); - external_module_name; - - call_name = `Nm_na ; - module_as_val = None; - val_send = `Nm_na ; - val_send_pipe = None; - set_index = false; - get_index = false; - new_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na - - } - -> - Js_global { name; external_module_name} - | {val_name = #bundle_source } - -> Location.raise_errorf ~loc "conflict attributes found" - | {splice ; - external_module_name = (Some _ as external_module_name); - - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - val_send = `Nm_na ; - val_send_pipe = None; - set_index = false; - get_index = false; - new_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; + end - } - -> - let name = string_of_bundle_source prim_name_or_pval_prim in - if arg_type_specs_length = 0 then + else + let splice = st.splice in + let arg_type_specs, new_arg_types_ty, arg_type_specs_length = + List.fold_right + (fun (label,ty,attr,loc) (arg_type_specs, arg_types, i) -> + let arg_label = Ast_core_type.label_name label in + let arg_type, new_ty = + match arg_label with + | Optional _ -> + + let arg_type , new_ty = get_arg_type ~nolabel:false true ty in + begin match arg_type with + | NonNullString _ -> + (* ?x:([`x of int ] [@bs.string]) does not make sense *) + Location.raise_errorf + ~loc + "[@@bs.string] does not work with optional when it has arities in label %s" label + | _ -> + arg_type, Ast_core_type.lift_option_type new_ty end + | Label _ | Empty -> + get_arg_type ~nolabel:(arg_label = Empty) false ty in + (if i = 0 && splice then + match arg_type with + | Array -> () + | _ -> Location.raise_errorf ~loc "[@@bs.splice] expect last type to array"); + ({ Ast_ffi_types.arg_label ; + arg_type + } :: arg_type_specs, + (label, new_ty,attr,loc) :: arg_types, + i + 1) + ) arg_types_ty + (match st with + | {val_send_pipe = Some obj} -> + let arg_type, new_ty = get_arg_type ~nolabel:true false obj in + [{ arg_label = Empty ; + arg_type + }], + ["", new_ty, [], obj.ptyp_loc] + ,0 + | {val_send_pipe = None } -> [],[], 0) in + + let ffi : Ast_ffi_types.ffi = match st with + | {set_index = true; + + val_name = `Nm_na; + external_module_name = None ; + module_as_val = None; + val_send = `Nm_na; + val_send_pipe = None; + splice = false; + get_index = false; + new_name = `Nm_na; + call_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + } + -> + if String.length prim_name <> 0 then + Location.raise_errorf ~loc "[@@bs.set_index] expect external names to be empty string"; + if arg_type_specs_length = 3 then + Js_set_index + else + Location.raise_errorf ~loc "Ill defined attribute [@@bs.set_index](arity of 3)" + + | {set_index = true; _} + -> + Location.raise_errorf ~loc "conflict attributes found" + + | {get_index = true; + + val_name = `Nm_na; + external_module_name = None ; + module_as_val = None; + val_send = `Nm_na; + val_send_pipe = None; + + splice = false; + new_name = `Nm_na; + call_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + } -> + if String.length prim_name <> 0 then + Location.raise_errorf ~loc "[@@bs.get_index] expect external names to be empty string"; + if arg_type_specs_length = 2 then + Js_get_index + else Location.raise_errorf ~loc "Ill defined attribute [@@bs.get_index] (arity of 2)" + + | {get_index = true; _} + -> Location.raise_errorf ~loc "conflict attributes found" + + + + | {module_as_val = Some external_module_name ; + + get_index = false; + val_name ; + new_name ; + + external_module_name = None ; + val_send = `Nm_na; + val_send_pipe = None; + splice ; + call_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + mk_obj = false ;} -> + begin match arg_types_ty, new_name, val_name with + | [], `Nm_na, _ -> Js_module_as_var external_module_name + | _, `Nm_na, _ -> Js_module_as_fn {splice; external_module_name } + | _, #bundle_source, #bundle_source -> + Location.raise_errorf ~loc "conflict attributes found" + | _, (`Nm_val _ | `Nm_external _) , `Nm_na + -> Js_module_as_class external_module_name + | _, `Nm_payload _ , `Nm_na + -> + Location.raise_errorf ~loc + "conflict attributes found: (bs.new should not carry payload here)" + + end + | {module_as_val = Some _} + -> Location.raise_errorf ~loc "conflict attributes found" + | {call_name = (`Nm_val name | `Nm_external name | `Nm_payload name) ; + splice; + external_module_name; + + val_name = `Nm_na ; + module_as_val = None; + val_send = `Nm_na ; + val_send_pipe = None; + + set_index = false; + get_index = false; + new_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na + } -> + Js_call {splice; name; external_module_name} + | {call_name = #bundle_source } + -> Location.raise_errorf ~loc "conflict attributes found" + + | {val_name = (`Nm_val name | `Nm_external name | `Nm_payload name); + external_module_name; + + call_name = `Nm_na ; + module_as_val = None; + val_send = `Nm_na ; + val_send_pipe = None; + set_index = false; + get_index = false; + new_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na + + } + -> Js_global { name; external_module_name} - else Js_call {splice; name; external_module_name} - | {val_send = (`Nm_val name | `Nm_external name | `Nm_payload name); - splice; - val_send_pipe = None; - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - set_index = false; - get_index = false; - new_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - external_module_name = None ; - } -> - if arg_type_specs_length > 0 then - Js_send {splice ; name; pipe = false} - else - Location.raise_errorf ~loc "Ill defined attribute [@@bs.send] (at least one argument)" - | {val_send = #bundle_source} - -> Location.raise_errorf ~loc "conflict attributes found" - - | {val_send_pipe = Some typ; - (* splice = (false as splice); *) - val_send = `Nm_na; - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - set_index = false; - get_index = false; - new_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - external_module_name = None ; - } -> - (** can be one argument *) - Js_send {splice ; - name = string_of_bundle_source prim_name_or_pval_prim; - pipe = true} - - | {val_send_pipe = Some _ } - -> Location.raise_errorf ~loc "conflict attributes found" - - | {new_name = (`Nm_val name | `Nm_external name | `Nm_payload name); - external_module_name; - - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - set_index = false; - get_index = false; - val_send = `Nm_na ; - val_send_pipe = None; - set_name = `Nm_na ; - get_name = `Nm_na ; - splice - } - -> Js_new {name; external_module_name; splice} - | {new_name = #bundle_source } - -> Location.raise_errorf ~loc "conflict attributes found" - - | {set_name = (`Nm_val name | `Nm_external name | `Nm_payload name); - - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - set_index = false; - get_index = false; - val_send = `Nm_na ; - val_send_pipe = None; - new_name = `Nm_na ; - get_name = `Nm_na ; - external_module_name = None - } - -> - if arg_type_specs_length = 2 then - Js_set name - else Location.raise_errorf ~loc "Ill defined attribute [@@bs.set] (two args required)" - - | {set_name = #bundle_source} - -> Location.raise_errorf ~loc "conflict attributes found" - - | {get_name = (`Nm_val name | `Nm_external name | `Nm_payload name); - - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - set_index = false; - get_index = false; - val_send = `Nm_na ; - val_send_pipe = None; - new_name = `Nm_na ; - set_name = `Nm_na ; - external_module_name = None - } - -> - if arg_type_specs_length = 1 then - Js_get name - else - Location.raise_errorf ~loc "Ill defined attribute [@@bs.get] (only one argument)" - | {get_name = #bundle_source} - -> Location.raise_errorf ~loc "conflict attributes found" - | _ -> Location.raise_errorf ~loc "Illegal attribute found" in - begin - Ast_ffi_types.check_ffi ~loc ffi; - (match ffi, new_result_type with - | Obj_create arg_labels , {ptyp_desc = Ptyp_any; _} - -> - (* special case: - {[ external f : int -> string -> _ = "" ]} - *) - let result = - Ast_core_type.make_obj ~loc ( - List.fold_right2 - (fun arg (label : Ast_core_type.arg_label) acc -> - match arg, label with - | (_, ty, _,_), Label s - -> (s , [], ty) :: acc - | (_, ty, _,_), Optional s - -> - (s, [], - Ast_comb.to_undefined_type loc @@ - Ast_core_type.extract_option_type_exn ty - ) :: acc - | (_, _, _,_), Empty -> acc - ) arg_types_ty arg_labels []) in - - List.fold_right (fun (label,ty,attrs,loc) acc -> - Ast_helper.Typ.arrow ~loc ~attrs label ty acc - ) new_arg_types_ty result - - (* Ast_core_type.replace_result type_annotation result *) - | _ -> - List.fold_right (fun (label,ty,attrs,loc) acc -> - Ast_helper.Typ.arrow ~loc ~attrs label ty acc - ) new_arg_types_ty new_result_type - ) , - prim_name, - (Ffi_bs (arg_type_specs, result_type_spec = Unit , ffi)), left_attrs - end + | {val_name = #bundle_source } + -> Location.raise_errorf ~loc "conflict attributes found" + | {splice ; + external_module_name = (Some _ as external_module_name); + + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + val_send = `Nm_na ; + val_send_pipe = None; + set_index = false; + get_index = false; + new_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + + } + -> + let name = string_of_bundle_source prim_name_or_pval_prim in + if arg_type_specs_length = 0 then + Js_global { name; external_module_name} + else Js_call {splice; name; external_module_name} + | {val_send = (`Nm_val name | `Nm_external name | `Nm_payload name); + splice; + val_send_pipe = None; + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + set_index = false; + get_index = false; + new_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + external_module_name = None ; + } -> + if arg_type_specs_length > 0 then + Js_send {splice ; name; pipe = false} + else + Location.raise_errorf ~loc "Ill defined attribute [@@bs.send] (at least one argument)" + | {val_send = #bundle_source} + -> Location.raise_errorf ~loc "conflict attributes found" + + | {val_send_pipe = Some typ; + (* splice = (false as splice); *) + val_send = `Nm_na; + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + set_index = false; + get_index = false; + new_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + external_module_name = None ; + } -> + (** can be one argument *) + Js_send {splice ; + name = string_of_bundle_source prim_name_or_pval_prim; + pipe = true} + + | {val_send_pipe = Some _ } + -> Location.raise_errorf ~loc "conflict attributes found" + + | {new_name = (`Nm_val name | `Nm_external name | `Nm_payload name); + external_module_name; + + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + set_index = false; + get_index = false; + val_send = `Nm_na ; + val_send_pipe = None; + set_name = `Nm_na ; + get_name = `Nm_na ; + splice + } + -> Js_new {name; external_module_name; splice} + | {new_name = #bundle_source } + -> Location.raise_errorf ~loc "conflict attributes found" + + | {set_name = (`Nm_val name | `Nm_external name | `Nm_payload name); + + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + set_index = false; + get_index = false; + val_send = `Nm_na ; + val_send_pipe = None; + new_name = `Nm_na ; + get_name = `Nm_na ; + external_module_name = None + } + -> + if arg_type_specs_length = 2 then + Js_set name + else Location.raise_errorf ~loc "Ill defined attribute [@@bs.set] (two args required)" + + | {set_name = #bundle_source} + -> Location.raise_errorf ~loc "conflict attributes found" + + | {get_name = (`Nm_val name | `Nm_external name | `Nm_payload name); + + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + set_index = false; + get_index = false; + val_send = `Nm_na ; + val_send_pipe = None; + new_name = `Nm_na ; + set_name = `Nm_na ; + external_module_name = None + } + -> + if arg_type_specs_length = 1 then + Js_get name + else + Location.raise_errorf ~loc "Ill defined attribute [@@bs.get] (only one argument)" + | {get_name = #bundle_source} + -> Location.raise_errorf ~loc "conflict attributes found" + | _ -> Location.raise_errorf ~loc "Illegal attribute found" in + begin + Ast_ffi_types.check_ffi ~loc ffi; + ( + List.fold_right (fun (label,ty,attrs,loc) acc -> + Ast_helper.Typ.arrow ~loc ~attrs label ty acc + ) new_arg_types_ty new_result_type + ) , + prim_name, + (Ffi_bs (arg_type_specs, result_type_spec = Extern_unit , ffi)), left_attrs + end let handle_attributes_as_string pval_loc @@ -28344,17 +28423,17 @@ let handle_attributes_as_string let pval_prim_of_labels labels = let encoding = - let (arg_kinds, vs) = + let arg_kinds = List.fold_right - (fun {Asttypes.loc ; txt } (arg_kinds,v) + (fun {Asttypes.loc ; txt } arg_kinds -> let arg_label = Ast_core_type.Label (Lam_methname.translate ~loc txt) in {Ast_ffi_types.arg_type = Nothing ; - arg_label } :: arg_kinds, arg_label :: v + arg_label } :: arg_kinds ) - labels ([],[]) in - Ast_ffi_types.to_string @@ - Ffi_bs (arg_kinds , false, Obj_create vs) in + labels [] in + Ast_ffi_types.to_string + (Ffi_obj_create arg_kinds) in [""; encoding] diff --git a/jscomp/bin/bsppx.ml b/jscomp/bin/bsppx.ml index 9bcc80acc2..765d583b97 100644 --- a/jscomp/bin/bsppx.ml +++ b/jscomp/bin/bsppx.ml @@ -5834,6 +5834,7 @@ module Lid : sig type t = Longident.t val val_unit : t val type_unit : t + val type_int : t val js_fn : t val js_meth : t val js_meth_callback : t @@ -5856,7 +5857,7 @@ val val_unit : expression_lit val type_unit : core_type_lit val type_string : core_type_lit - +val type_int : core_type_lit val type_any : core_type_lit val pat_unit : pattern_lit @@ -5895,6 +5896,7 @@ module Lid = struct let val_unit : t = Lident "()" let type_unit : t = Lident "unit" let type_string : t = Lident "string" + let type_int : t = Lident "int" (* use *predef* *) (* TODO should be renamed in to {!Js.fn} *) (* TODO should be moved into {!Js.t} Later *) let js_fn = Longident.Ldot (Lident "Js", "fn") @@ -5915,7 +5917,8 @@ module No_loc = struct Ast_helper.Exp.construct {txt = Lid.val_unit; loc } None let type_unit = Ast_helper.Typ.mk (Ptyp_constr ({ txt = Lid.type_unit; loc}, [])) - + let type_int = + Ast_helper.Typ.mk (Ptyp_constr ({txt = Lid.type_int; loc}, [])) let type_string = Ast_helper.Typ.mk (Ptyp_constr ({ txt = Lid.type_string; loc}, [])) @@ -5948,6 +5951,12 @@ let type_string ?loc () = | Some loc -> Ast_helper.Typ.mk ~loc (Ptyp_constr ({ txt = Lid.type_string; loc}, [])) +let type_int ?loc () = + match loc with + | None -> No_loc.type_int + | Some loc -> + Ast_helper.Typ.mk ~loc (Ptyp_constr ({ txt = Lid.type_int; loc}, [])) + let type_any ?loc () = match loc with | None -> No_loc.type_any @@ -7671,6 +7680,8 @@ type t = Parsetree.core_type val extract_option_type_exn : t -> t +val lift_option_type : t -> t +val is_any : t -> bool val replace_result : t -> t -> t val is_unit : t -> bool @@ -7684,7 +7695,7 @@ type arg_type = | NonNullString of (int * string) list | Int of (int * int ) list | Array - | Unit + | Extern_unit | Nothing | Ignore @@ -7711,6 +7722,7 @@ val make_obj : (string * Parsetree.attributes * t) list -> t +val is_optional_label : string -> bool end = struct #1 "ast_core_type.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. @@ -7744,11 +7756,11 @@ type arg_label = | Empty (* it will be ignored , side effect will be recorded *) type arg_type = - | NullString of (int * string) list - | NonNullString of (int * string) list + | NullString of (int * string) list (* `a does not have any value*) + | NonNullString of (int * string) list (* `a of int *) | Int of (int * int ) list | Array - | Unit + | Extern_unit | Nothing | Ignore @@ -7764,7 +7776,23 @@ let extract_option_type_exn (ty : t) = | _ -> assert false end - +let predef_option : Longident.t = Longident.Ldot (Lident "*predef*", "option") +let predef_int : Longident.t = Ldot (Lident "*predef*", "int") + + +let lift_option_type (ty:t) : t = + {ptyp_desc = + Ptyp_constr( + {txt = predef_option; + loc = ty.ptyp_loc} + , [ty]); + ptyp_loc = ty.ptyp_loc; + ptyp_attributes = [] + } + +let is_any (ty : t) = + match ty with {ptyp_desc = Ptyp_any} -> true | _ -> false + open Ast_helper let replace_result ty result = @@ -7788,12 +7816,12 @@ let is_array (ty : t) = | Ptyp_constr({txt =Lident "array"}, [_]) -> true | _ -> false -let is_optional l = +let is_optional_label l = String.length l > 0 && l.[0] = '?' let label_name l : arg_label = if l = "" then Empty else - if is_optional l + if is_optional_label l then Optional (String.sub l 1 (String.length l - 1)) else Label l @@ -8134,9 +8162,10 @@ type arg_kind = arg_label : arg_label } +type obj_create = arg_kind list type ffi = - | Obj_create of arg_label list + (* | Obj_create of obj_create*) | Js_global of js_global_val | Js_module_as_var of external_module_name | Js_module_as_fn of js_module_as_fn @@ -8151,6 +8180,7 @@ type ffi = type t = | Ffi_bs of arg_kind list * bool * ffi + | Ffi_obj_create of obj_create | Ffi_normal (* When it's normal, it is handled as normal c functional ffi call *) @@ -8234,10 +8264,10 @@ type arg_kind = arg_type : arg_type; arg_label : arg_label } - +type obj_create = arg_kind list type ffi = - | Obj_create of arg_label list + (* | Obj_create of obj_create *) | Js_global of js_global_val | Js_module_as_var of external_module_name | Js_module_as_fn of js_module_as_fn @@ -8268,14 +8298,15 @@ let name_of_ffi ffi = | Js_global v -> Printf.sprintf "[@@bs.val] %S " v.name - | Obj_create _ -> - Printf.sprintf "[@@bs.obj]" + (* | Obj_create _ -> + Printf.sprintf "[@@bs.obj]" *) type t = | Ffi_bs of arg_kind list * bool * ffi (** [Ffi_bs(args,return,ffi) ] [return] means return value is unit or not, [true] means is [unit] *) + | Ffi_obj_create of obj_create | Ffi_normal (* When it's normal, it is handled as normal c functional ffi call *) @@ -8341,7 +8372,7 @@ let check_ffi ?loc ffi = | Js_set name | Js_get name -> valid_method_name ?loc name - | Obj_create _ -> () + (* | Obj_create _ -> () *) | Js_get_index | Js_set_index -> () @@ -9595,10 +9626,11 @@ end = struct ]} The result type would be [ hi:string ] *) -let get_arg_type - ({ptyp_desc; ptyp_attributes; ptyp_loc = loc} as ptyp : Ast_core_type.t) : +let get_arg_type ~nolabel optional + (ptyp : Ast_core_type.t) : Ast_core_type.arg_type * Ast_core_type.t = - match Ast_attributes.process_bs_string_int ptyp_attributes, ptyp_desc with + let ptyp = if optional then Ast_core_type.extract_option_type_exn ptyp else ptyp in + match Ast_attributes.process_bs_string_int ptyp.ptyp_attributes, ptyp.ptyp_desc with | (`String, ptyp_attributes), Ptyp_variant ( row_fields, Closed, None) -> let case, result, row_fields = @@ -9626,16 +9658,16 @@ let get_arg_type `NonNull, ((Ext_pervasives.hash_variant label, label) :: acc), (tag :: row_fields) end - | _ -> Location.raise_errorf ~loc "Not a valid string type" + | _ -> Location.raise_errorf ~loc:ptyp.ptyp_loc "Not a valid string type" ) row_fields (`Nothing, [], [])) in (match case with - | `Nothing -> Location.raise_errorf ~loc "Not a valid string type" + | `Nothing -> Location.raise_errorf ~loc:ptyp.ptyp_loc "Not a valid string type" | `Null -> NullString result | `NonNull -> NonNullString result) , {ptyp with ptyp_desc = Ptyp_variant(row_fields, Closed, None); ptyp_attributes ; } - | (`String, _), _ -> Location.raise_errorf ~loc "Not a valid string type" + | (`String, _), _ -> Location.raise_errorf ~loc:ptyp.ptyp_loc "Not a valid string type" | (`Ignore, ptyp_attributes), _ -> (Ignore, {ptyp with ptyp_attributes}) @@ -9654,7 +9686,7 @@ let get_arg_type i + 1 , ((Ext_pervasives.hash_variant label , i):: acc ), rtag::row_fields end - | _ -> Location.raise_errorf ~loc "Not a valid string type" + | _ -> Location.raise_errorf ~loc:ptyp.ptyp_loc "Not a valid string type" ) (0, [],[]) row_fields) in Int (List.rev acc), {ptyp with @@ -9662,19 +9694,19 @@ let get_arg_type ptyp_attributes } - | (`Int, _), _ -> Location.raise_errorf ~loc "Not a valid string type" + | (`Int, _), _ -> Location.raise_errorf ~loc:ptyp.ptyp_loc "Not a valid string type" | (`Nothing, ptyp_attributes), ptyp_desc -> begin match ptyp_desc with | Ptyp_constr ({txt = Lident "bool"}, []) -> - Bs_warnings.prerr_warning loc Unsafe_ffi_bool_type; + Bs_warnings.prerr_warning ptyp.ptyp_loc Unsafe_ffi_bool_type; Nothing | Ptyp_constr ({txt = Lident "unit"}, []) - -> Unit + -> if nolabel then Extern_unit else Nothing | Ptyp_constr ({txt = Lident "array"}, [_]) -> Array | Ptyp_variant _ -> - Bs_warnings.prerr_warning loc Unsafe_poly_variant_type; + Bs_warnings.prerr_warning ptyp.ptyp_loc Unsafe_poly_variant_type; Nothing | _ -> Nothing @@ -9810,7 +9842,7 @@ let process_external_attributes (init_st, []) prim_attributes -let list_of_arrow_clean_option_label (ty : Parsetree.core_type) = +let list_of_arrow (ty : Parsetree.core_type) = let rec aux (ty : Parsetree.core_type) acc = match ty.ptyp_desc with | Ptyp_arrow(label,t1,t2) -> @@ -9820,6 +9852,7 @@ let list_of_arrow_clean_option_label (ty : Parsetree.core_type) = | return_type -> ty, List.rev acc in aux ty [] + (** Note that the passed [type_annotation] is already processed by visitor pattern before *) let handle_attributes @@ -9833,43 +9866,18 @@ let handle_attributes else `Nm_external prim_name (* need check name *) in let result_type, arg_types_ty = - list_of_arrow_clean_option_label type_annotation in + list_of_arrow type_annotation in let result_type_spec, new_result_type = - get_arg_type result_type in + get_arg_type ~nolabel:true false result_type in (* result type can not be labeled *) let (st, left_attrs) = process_external_attributes (arg_types_ty = []) prim_name_or_pval_prim pval_prim prim_attributes in - let splice = st.splice in - let arg_type_specs, new_arg_types_ty, arg_type_specs_length = - List.fold_right - (fun (label,ty,attr,loc) (arg_type_specs, arg_types, i) -> - let arg_type, new_ty = get_arg_type ty in - (if i = 0 && splice then - match arg_type with - | Array -> () - | _ -> Location.raise_errorf ~loc "[@@bs.splice] expect last type to array"); - ({ Ast_ffi_types.arg_label = Ast_core_type.label_name label ; - arg_type - } :: arg_type_specs, - (label, new_ty,attr,loc) :: arg_types, - i + 1) - ) arg_types_ty - (match st with - | {val_send_pipe = Some obj} -> - let arg_type, new_ty = get_arg_type obj in - [{ arg_label = Empty ; - arg_type - }], - ["", new_ty, [], obj.ptyp_loc] - ,0 - | {val_send_pipe = None } -> [],[], 0) in - - - let ffi = - match st with - | { mk_obj = true; + + if st.mk_obj then + begin match st with + | { val_name = `Nm_na; external_module_name = None ; module_as_val = None; @@ -9881,314 +9889,385 @@ let handle_attributes set_name = `Nm_na ; get_name = `Nm_na ; get_index = false ; - } -> - if String.length prim_name <> 0 then - Location.raise_errorf ~loc "[@@bs.obj] expect external names to be empty string"; - Ast_ffi_types.Obj_create (List.map (function - | {Ast_ffi_types.arg_label = (Empty as l) ; arg_type = Unit } - -> l - | {arg_label = Empty ; arg_type = _ } - -> Location.raise_errorf ~loc "expect label, optional, or unit here" - | {arg_label = (Label _) ; arg_type = (Ignore | Unit) ; } - -> Empty - | {arg_label = Label name ; arg_type = (Nothing | Array)} -> - Label (Lam_methname.translate ~loc name) - | {arg_label = Label l ; arg_type = (NullString _ | NonNullString _ | Int _ ) } - -> Location.raise_errorf ~loc - "bs.obj label %s does not support such arg type" l - | {arg_label = Optional name ; arg_type = (Nothing | Array | Unit | Ignore)} - -> Optional (Lam_methname.translate ~loc name) - | {arg_label = Optional l ; arg_type = (NullString _ | NonNullString _ | Int _)} - -> Location.raise_errorf ~loc - "bs.obj optional %s does not support such arg type" l ) - arg_type_specs)(* Need fetch label here, for better error message *) - | {mk_obj = true; _} - -> - Location.raise_errorf ~loc "conflict attributes found" - | {set_index = true; - - val_name = `Nm_na; - external_module_name = None ; - module_as_val = None; - val_send = `Nm_na; - val_send_pipe = None; - splice = false; - get_index = false; - new_name = `Nm_na; - call_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - mk_obj = false ; - - } - -> - if String.length prim_name <> 0 then - Location.raise_errorf ~loc "[@@bs.set_index] expect external names to be empty string"; - if arg_type_specs_length = 3 then - Js_set_index - else - Location.raise_errorf ~loc "Ill defined attribute [@@bs.set_index](arity of 3)" + } -> + if String.length prim_name <> 0 then + Location.raise_errorf ~loc "[@@bs.obj] expect external names to be empty string"; + let arg_kinds, new_arg_types_ty, result_types = + List.fold_right + (fun (label,ty,attr,loc) ( arg_labels, arg_types, result_types) -> + let arg_label = Ast_core_type.label_name label in + let new_arg_label, new_ty, output_tys = + match arg_label with + | Empty -> + let arg_type, new_ty = get_arg_type ~nolabel:true false ty in + begin match arg_type with + | Extern_unit -> { Ast_ffi_types. arg_label; arg_type }, new_ty, result_types + | _ -> + Location.raise_errorf ~loc "expect label, optional, or unit here" + end + | Label name -> + let arg_type, new_ty = get_arg_type ~nolabel:false false ty in + begin match arg_type with + | Ignore -> { arg_label = Empty ; arg_type }, new_ty, result_types + + | Nothing | Array -> + let s = (Lam_methname.translate ~loc name) in + {arg_label = Label s ; arg_type }, new_ty, + ((name , [], new_ty) :: result_types) + | Int _ -> + let s = Lam_methname.translate ~loc name in + {arg_label = Label s; arg_type}, new_ty, ((name, [], Ast_literal.type_int ~loc ()) :: result_types) + | NullString _ -> + let s = Lam_methname.translate ~loc name in + {arg_label = Label s; arg_type}, new_ty, + ((name, [], Ast_literal.type_string ~loc ()) :: result_types) + | Extern_unit -> assert false + | NonNullString _ + -> + Location.raise_errorf ~loc + "bs.obj label %s does not support such arg type" name + end + | Optional name -> + let arg_type, new_ty_extract = get_arg_type ~nolabel:false true ty in + let new_ty = Ast_core_type.lift_option_type new_ty_extract in + begin match arg_type with + | Ignore -> + {arg_label = Empty ; arg_type}, new_ty, result_types + + | Nothing | Array -> + let s = (Lam_methname.translate ~loc name) in + {arg_label = Optional s; arg_type}, new_ty, + ( (name, [], Ast_comb.to_undefined_type loc new_ty_extract) :: result_types) + | Int _ -> + let s = Lam_methname.translate ~loc name in + {arg_label = Optional s ; arg_type }, new_ty, + ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_int ~loc ()) :: result_types) + | NullString _ -> + let s = Lam_methname.translate ~loc name in + {arg_label = Optional s ; arg_type }, new_ty, + ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_string ~loc ()) :: result_types) + | Extern_unit -> assert false + | NonNullString _ + -> + Location.raise_errorf ~loc + "bs.obj label %s does not support such arg type" name + end + in + ( + new_arg_label::arg_labels, + (label, new_ty,attr,loc) :: arg_types, + output_tys)) arg_types_ty + ( [], [], []) in + let result = + if Ast_core_type.is_any new_result_type then + Ast_core_type.make_obj ~loc result_types + else new_result_type + in + begin + ( + List.fold_right (fun (label,ty,attrs,loc) acc -> + Ast_helper.Typ.arrow ~loc ~attrs label ty acc + ) new_arg_types_ty result + ) , + prim_name, + Ffi_obj_create arg_kinds, + left_attrs + end - | {set_index = true; _} - -> - Location.raise_errorf ~loc "conflict attributes found" - - | {get_index = true; - - val_name = `Nm_na; - external_module_name = None ; - module_as_val = None; - val_send = `Nm_na; - val_send_pipe = None; - - splice = false; - new_name = `Nm_na; - call_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - mk_obj = false ; - } -> - if String.length prim_name <> 0 then - Location.raise_errorf ~loc "[@@bs.get_index] expect external names to be empty string"; - if arg_type_specs_length = 2 then - Js_get_index - else Location.raise_errorf ~loc "Ill defined attribute [@@bs.get_index] (arity of 2)" - - | {get_index = true; _} - -> Location.raise_errorf ~loc "conflict attributes found" - - - (*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] ]} - *) - | {module_as_val = Some external_module_name ; - - get_index = false; - val_name ; - new_name ; - - external_module_name = None ; - val_send = `Nm_na; - val_send_pipe = None; - splice ; - call_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - mk_obj = false ;} -> - begin match arg_types_ty, new_name, val_name with - | [], `Nm_na, _ -> Js_module_as_var external_module_name - | _, `Nm_na, _ -> Js_module_as_fn {splice; external_module_name } - | _, #bundle_source, #bundle_source -> - Location.raise_errorf ~loc "conflict attributes found" - | _, (`Nm_val _ | `Nm_external _) , `Nm_na - -> Js_module_as_class external_module_name - | _, `Nm_payload _ , `Nm_na - -> - Location.raise_errorf ~loc - "conflict attributes found: (bs.new should not carry payload here)" + | _ -> Location.raise_errorf ~loc "conflict attributes found [@@bs.obj]" - end - | {module_as_val = Some _} - -> Location.raise_errorf ~loc "conflict attributes found" - | {call_name = (`Nm_val name | `Nm_external name | `Nm_payload name) ; - splice; - external_module_name; - - val_name = `Nm_na ; - module_as_val = None; - val_send = `Nm_na ; - val_send_pipe = None; - - set_index = false; - get_index = false; - new_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na - } -> - Js_call {splice; name; external_module_name} - | {call_name = #bundle_source } - -> Location.raise_errorf ~loc "conflict attributes found" - - | {val_name = (`Nm_val name | `Nm_external name | `Nm_payload name); - external_module_name; - - call_name = `Nm_na ; - module_as_val = None; - val_send = `Nm_na ; - val_send_pipe = None; - set_index = false; - get_index = false; - new_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na - - } - -> - Js_global { name; external_module_name} - | {val_name = #bundle_source } - -> Location.raise_errorf ~loc "conflict attributes found" - | {splice ; - external_module_name = (Some _ as external_module_name); - - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - val_send = `Nm_na ; - val_send_pipe = None; - set_index = false; - get_index = false; - new_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; + end - } - -> - let name = string_of_bundle_source prim_name_or_pval_prim in - if arg_type_specs_length = 0 then + else + let splice = st.splice in + let arg_type_specs, new_arg_types_ty, arg_type_specs_length = + List.fold_right + (fun (label,ty,attr,loc) (arg_type_specs, arg_types, i) -> + let arg_label = Ast_core_type.label_name label in + let arg_type, new_ty = + match arg_label with + | Optional _ -> + + let arg_type , new_ty = get_arg_type ~nolabel:false true ty in + begin match arg_type with + | NonNullString _ -> + (* ?x:([`x of int ] [@bs.string]) does not make sense *) + Location.raise_errorf + ~loc + "[@@bs.string] does not work with optional when it has arities in label %s" label + | _ -> + arg_type, Ast_core_type.lift_option_type new_ty end + | Label _ | Empty -> + get_arg_type ~nolabel:(arg_label = Empty) false ty in + (if i = 0 && splice then + match arg_type with + | Array -> () + | _ -> Location.raise_errorf ~loc "[@@bs.splice] expect last type to array"); + ({ Ast_ffi_types.arg_label ; + arg_type + } :: arg_type_specs, + (label, new_ty,attr,loc) :: arg_types, + i + 1) + ) arg_types_ty + (match st with + | {val_send_pipe = Some obj} -> + let arg_type, new_ty = get_arg_type ~nolabel:true false obj in + [{ arg_label = Empty ; + arg_type + }], + ["", new_ty, [], obj.ptyp_loc] + ,0 + | {val_send_pipe = None } -> [],[], 0) in + + let ffi : Ast_ffi_types.ffi = match st with + | {set_index = true; + + val_name = `Nm_na; + external_module_name = None ; + module_as_val = None; + val_send = `Nm_na; + val_send_pipe = None; + splice = false; + get_index = false; + new_name = `Nm_na; + call_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + } + -> + if String.length prim_name <> 0 then + Location.raise_errorf ~loc "[@@bs.set_index] expect external names to be empty string"; + if arg_type_specs_length = 3 then + Js_set_index + else + Location.raise_errorf ~loc "Ill defined attribute [@@bs.set_index](arity of 3)" + + | {set_index = true; _} + -> + Location.raise_errorf ~loc "conflict attributes found" + + | {get_index = true; + + val_name = `Nm_na; + external_module_name = None ; + module_as_val = None; + val_send = `Nm_na; + val_send_pipe = None; + + splice = false; + new_name = `Nm_na; + call_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + } -> + if String.length prim_name <> 0 then + Location.raise_errorf ~loc "[@@bs.get_index] expect external names to be empty string"; + if arg_type_specs_length = 2 then + Js_get_index + else Location.raise_errorf ~loc "Ill defined attribute [@@bs.get_index] (arity of 2)" + + | {get_index = true; _} + -> Location.raise_errorf ~loc "conflict attributes found" + + + + | {module_as_val = Some external_module_name ; + + get_index = false; + val_name ; + new_name ; + + external_module_name = None ; + val_send = `Nm_na; + val_send_pipe = None; + splice ; + call_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + mk_obj = false ;} -> + begin match arg_types_ty, new_name, val_name with + | [], `Nm_na, _ -> Js_module_as_var external_module_name + | _, `Nm_na, _ -> Js_module_as_fn {splice; external_module_name } + | _, #bundle_source, #bundle_source -> + Location.raise_errorf ~loc "conflict attributes found" + | _, (`Nm_val _ | `Nm_external _) , `Nm_na + -> Js_module_as_class external_module_name + | _, `Nm_payload _ , `Nm_na + -> + Location.raise_errorf ~loc + "conflict attributes found: (bs.new should not carry payload here)" + + end + | {module_as_val = Some _} + -> Location.raise_errorf ~loc "conflict attributes found" + | {call_name = (`Nm_val name | `Nm_external name | `Nm_payload name) ; + splice; + external_module_name; + + val_name = `Nm_na ; + module_as_val = None; + val_send = `Nm_na ; + val_send_pipe = None; + + set_index = false; + get_index = false; + new_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na + } -> + Js_call {splice; name; external_module_name} + | {call_name = #bundle_source } + -> Location.raise_errorf ~loc "conflict attributes found" + + | {val_name = (`Nm_val name | `Nm_external name | `Nm_payload name); + external_module_name; + + call_name = `Nm_na ; + module_as_val = None; + val_send = `Nm_na ; + val_send_pipe = None; + set_index = false; + get_index = false; + new_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na + + } + -> Js_global { name; external_module_name} - else Js_call {splice; name; external_module_name} - | {val_send = (`Nm_val name | `Nm_external name | `Nm_payload name); - splice; - val_send_pipe = None; - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - set_index = false; - get_index = false; - new_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - external_module_name = None ; - } -> - if arg_type_specs_length > 0 then - Js_send {splice ; name; pipe = false} - else - Location.raise_errorf ~loc "Ill defined attribute [@@bs.send] (at least one argument)" - | {val_send = #bundle_source} - -> Location.raise_errorf ~loc "conflict attributes found" - - | {val_send_pipe = Some typ; - (* splice = (false as splice); *) - val_send = `Nm_na; - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - set_index = false; - get_index = false; - new_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - external_module_name = None ; - } -> - (** can be one argument *) - Js_send {splice ; - name = string_of_bundle_source prim_name_or_pval_prim; - pipe = true} - - | {val_send_pipe = Some _ } - -> Location.raise_errorf ~loc "conflict attributes found" - - | {new_name = (`Nm_val name | `Nm_external name | `Nm_payload name); - external_module_name; - - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - set_index = false; - get_index = false; - val_send = `Nm_na ; - val_send_pipe = None; - set_name = `Nm_na ; - get_name = `Nm_na ; - splice - } - -> Js_new {name; external_module_name; splice} - | {new_name = #bundle_source } - -> Location.raise_errorf ~loc "conflict attributes found" - - | {set_name = (`Nm_val name | `Nm_external name | `Nm_payload name); - - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - set_index = false; - get_index = false; - val_send = `Nm_na ; - val_send_pipe = None; - new_name = `Nm_na ; - get_name = `Nm_na ; - external_module_name = None - } - -> - if arg_type_specs_length = 2 then - Js_set name - else Location.raise_errorf ~loc "Ill defined attribute [@@bs.set] (two args required)" - - | {set_name = #bundle_source} - -> Location.raise_errorf ~loc "conflict attributes found" - - | {get_name = (`Nm_val name | `Nm_external name | `Nm_payload name); - - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - set_index = false; - get_index = false; - val_send = `Nm_na ; - val_send_pipe = None; - new_name = `Nm_na ; - set_name = `Nm_na ; - external_module_name = None - } - -> - if arg_type_specs_length = 1 then - Js_get name - else - Location.raise_errorf ~loc "Ill defined attribute [@@bs.get] (only one argument)" - | {get_name = #bundle_source} - -> Location.raise_errorf ~loc "conflict attributes found" - | _ -> Location.raise_errorf ~loc "Illegal attribute found" in - begin - Ast_ffi_types.check_ffi ~loc ffi; - (match ffi, new_result_type with - | Obj_create arg_labels , {ptyp_desc = Ptyp_any; _} - -> - (* special case: - {[ external f : int -> string -> _ = "" ]} - *) - let result = - Ast_core_type.make_obj ~loc ( - List.fold_right2 - (fun arg (label : Ast_core_type.arg_label) acc -> - match arg, label with - | (_, ty, _,_), Label s - -> (s , [], ty) :: acc - | (_, ty, _,_), Optional s - -> - (s, [], - Ast_comb.to_undefined_type loc @@ - Ast_core_type.extract_option_type_exn ty - ) :: acc - | (_, _, _,_), Empty -> acc - ) arg_types_ty arg_labels []) in - - List.fold_right (fun (label,ty,attrs,loc) acc -> - Ast_helper.Typ.arrow ~loc ~attrs label ty acc - ) new_arg_types_ty result - - (* Ast_core_type.replace_result type_annotation result *) - | _ -> - List.fold_right (fun (label,ty,attrs,loc) acc -> - Ast_helper.Typ.arrow ~loc ~attrs label ty acc - ) new_arg_types_ty new_result_type - ) , - prim_name, - (Ffi_bs (arg_type_specs, result_type_spec = Unit , ffi)), left_attrs - end + | {val_name = #bundle_source } + -> Location.raise_errorf ~loc "conflict attributes found" + | {splice ; + external_module_name = (Some _ as external_module_name); + + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + val_send = `Nm_na ; + val_send_pipe = None; + set_index = false; + get_index = false; + new_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + + } + -> + let name = string_of_bundle_source prim_name_or_pval_prim in + if arg_type_specs_length = 0 then + Js_global { name; external_module_name} + else Js_call {splice; name; external_module_name} + | {val_send = (`Nm_val name | `Nm_external name | `Nm_payload name); + splice; + val_send_pipe = None; + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + set_index = false; + get_index = false; + new_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + external_module_name = None ; + } -> + if arg_type_specs_length > 0 then + Js_send {splice ; name; pipe = false} + else + Location.raise_errorf ~loc "Ill defined attribute [@@bs.send] (at least one argument)" + | {val_send = #bundle_source} + -> Location.raise_errorf ~loc "conflict attributes found" + + | {val_send_pipe = Some typ; + (* splice = (false as splice); *) + val_send = `Nm_na; + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + set_index = false; + get_index = false; + new_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + external_module_name = None ; + } -> + (** can be one argument *) + Js_send {splice ; + name = string_of_bundle_source prim_name_or_pval_prim; + pipe = true} + + | {val_send_pipe = Some _ } + -> Location.raise_errorf ~loc "conflict attributes found" + + | {new_name = (`Nm_val name | `Nm_external name | `Nm_payload name); + external_module_name; + + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + set_index = false; + get_index = false; + val_send = `Nm_na ; + val_send_pipe = None; + set_name = `Nm_na ; + get_name = `Nm_na ; + splice + } + -> Js_new {name; external_module_name; splice} + | {new_name = #bundle_source } + -> Location.raise_errorf ~loc "conflict attributes found" + + | {set_name = (`Nm_val name | `Nm_external name | `Nm_payload name); + + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + set_index = false; + get_index = false; + val_send = `Nm_na ; + val_send_pipe = None; + new_name = `Nm_na ; + get_name = `Nm_na ; + external_module_name = None + } + -> + if arg_type_specs_length = 2 then + Js_set name + else Location.raise_errorf ~loc "Ill defined attribute [@@bs.set] (two args required)" + + | {set_name = #bundle_source} + -> Location.raise_errorf ~loc "conflict attributes found" + + | {get_name = (`Nm_val name | `Nm_external name | `Nm_payload name); + + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + set_index = false; + get_index = false; + val_send = `Nm_na ; + val_send_pipe = None; + new_name = `Nm_na ; + set_name = `Nm_na ; + external_module_name = None + } + -> + if arg_type_specs_length = 1 then + Js_get name + else + Location.raise_errorf ~loc "Ill defined attribute [@@bs.get] (only one argument)" + | {get_name = #bundle_source} + -> Location.raise_errorf ~loc "conflict attributes found" + | _ -> Location.raise_errorf ~loc "Illegal attribute found" in + begin + Ast_ffi_types.check_ffi ~loc ffi; + ( + List.fold_right (fun (label,ty,attrs,loc) acc -> + Ast_helper.Typ.arrow ~loc ~attrs label ty acc + ) new_arg_types_ty new_result_type + ) , + prim_name, + (Ffi_bs (arg_type_specs, result_type_spec = Extern_unit , ffi)), left_attrs + end let handle_attributes_as_string pval_loc @@ -10200,17 +10279,17 @@ let handle_attributes_as_string let pval_prim_of_labels labels = let encoding = - let (arg_kinds, vs) = + let arg_kinds = List.fold_right - (fun {Asttypes.loc ; txt } (arg_kinds,v) + (fun {Asttypes.loc ; txt } arg_kinds -> let arg_label = Ast_core_type.Label (Lam_methname.translate ~loc txt) in {Ast_ffi_types.arg_type = Nothing ; - arg_label } :: arg_kinds, arg_label :: v + arg_label } :: arg_kinds ) - labels ([],[]) in - Ast_ffi_types.to_string @@ - Ffi_bs (arg_kinds , false, Obj_create vs) in + labels [] in + Ast_ffi_types.to_string + (Ffi_obj_create arg_kinds) in [""; encoding] diff --git a/jscomp/bin/whole_compiler.ml b/jscomp/bin/whole_compiler.ml index 508ea7382c..e94aa95899 100644 --- a/jscomp/bin/whole_compiler.ml +++ b/jscomp/bin/whole_compiler.ml @@ -66576,6 +66576,8 @@ let dot ?comment (e0 : t) (e1 : string) : t = let undefined = var Ext_ident.undefined + + let nil = var Ext_ident.nil (** coupled with the runtime *) @@ -87659,6 +87661,7 @@ module Lid : sig type t = Longident.t val val_unit : t val type_unit : t + val type_int : t val js_fn : t val js_meth : t val js_meth_callback : t @@ -87681,7 +87684,7 @@ val val_unit : expression_lit val type_unit : core_type_lit val type_string : core_type_lit - +val type_int : core_type_lit val type_any : core_type_lit val pat_unit : pattern_lit @@ -87720,6 +87723,7 @@ module Lid = struct let val_unit : t = Lident "()" let type_unit : t = Lident "unit" let type_string : t = Lident "string" + let type_int : t = Lident "int" (* use *predef* *) (* TODO should be renamed in to {!Js.fn} *) (* TODO should be moved into {!Js.t} Later *) let js_fn = Longident.Ldot (Lident "Js", "fn") @@ -87740,7 +87744,8 @@ module No_loc = struct Ast_helper.Exp.construct {txt = Lid.val_unit; loc } None let type_unit = Ast_helper.Typ.mk (Ptyp_constr ({ txt = Lid.type_unit; loc}, [])) - + let type_int = + Ast_helper.Typ.mk (Ptyp_constr ({txt = Lid.type_int; loc}, [])) let type_string = Ast_helper.Typ.mk (Ptyp_constr ({ txt = Lid.type_string; loc}, [])) @@ -87773,6 +87778,12 @@ let type_string ?loc () = | Some loc -> Ast_helper.Typ.mk ~loc (Ptyp_constr ({ txt = Lid.type_string; loc}, [])) +let type_int ?loc () = + match loc with + | None -> No_loc.type_int + | Some loc -> + Ast_helper.Typ.mk ~loc (Ptyp_constr ({ txt = Lid.type_int; loc}, [])) + let type_any ?loc () = match loc with | None -> No_loc.type_any @@ -87970,6 +87981,8 @@ type t = Parsetree.core_type val extract_option_type_exn : t -> t +val lift_option_type : t -> t +val is_any : t -> bool val replace_result : t -> t -> t val is_unit : t -> bool @@ -87983,7 +87996,7 @@ type arg_type = | NonNullString of (int * string) list | Int of (int * int ) list | Array - | Unit + | Extern_unit | Nothing | Ignore @@ -88010,6 +88023,7 @@ val make_obj : (string * Parsetree.attributes * t) list -> t +val is_optional_label : string -> bool end = struct #1 "ast_core_type.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. @@ -88043,11 +88057,11 @@ type arg_label = | Empty (* it will be ignored , side effect will be recorded *) type arg_type = - | NullString of (int * string) list - | NonNullString of (int * string) list + | NullString of (int * string) list (* `a does not have any value*) + | NonNullString of (int * string) list (* `a of int *) | Int of (int * int ) list | Array - | Unit + | Extern_unit | Nothing | Ignore @@ -88063,7 +88077,23 @@ let extract_option_type_exn (ty : t) = | _ -> assert false end - +let predef_option : Longident.t = Longident.Ldot (Lident "*predef*", "option") +let predef_int : Longident.t = Ldot (Lident "*predef*", "int") + + +let lift_option_type (ty:t) : t = + {ptyp_desc = + Ptyp_constr( + {txt = predef_option; + loc = ty.ptyp_loc} + , [ty]); + ptyp_loc = ty.ptyp_loc; + ptyp_attributes = [] + } + +let is_any (ty : t) = + match ty with {ptyp_desc = Ptyp_any} -> true | _ -> false + open Ast_helper let replace_result ty result = @@ -88087,12 +88117,12 @@ let is_array (ty : t) = | Ptyp_constr({txt =Lident "array"}, [_]) -> true | _ -> false -let is_optional l = +let is_optional_label l = String.length l > 0 && l.[0] = '?' let label_name l : arg_label = if l = "" then Empty else - if is_optional l + if is_optional_label l then Optional (String.sub l 1 (String.length l - 1)) else Label l @@ -88194,9 +88224,10 @@ type arg_kind = arg_label : arg_label } +type obj_create = arg_kind list type ffi = - | Obj_create of arg_label list + (* | Obj_create of obj_create*) | Js_global of js_global_val | Js_module_as_var of external_module_name | Js_module_as_fn of js_module_as_fn @@ -88211,6 +88242,7 @@ type ffi = type t = | Ffi_bs of arg_kind list * bool * ffi + | Ffi_obj_create of obj_create | Ffi_normal (* When it's normal, it is handled as normal c functional ffi call *) @@ -88294,10 +88326,10 @@ type arg_kind = arg_type : arg_type; arg_label : arg_label } - +type obj_create = arg_kind list type ffi = - | Obj_create of arg_label list + (* | Obj_create of obj_create *) | Js_global of js_global_val | Js_module_as_var of external_module_name | Js_module_as_fn of js_module_as_fn @@ -88328,14 +88360,15 @@ let name_of_ffi ffi = | Js_global v -> Printf.sprintf "[@@bs.val] %S " v.name - | Obj_create _ -> - Printf.sprintf "[@@bs.obj]" + (* | Obj_create _ -> + Printf.sprintf "[@@bs.obj]" *) type t = | Ffi_bs of arg_kind list * bool * ffi (** [Ffi_bs(args,return,ffi) ] [return] means return value is unit or not, [true] means is [unit] *) + | Ffi_obj_create of obj_create | Ffi_normal (* When it's normal, it is handled as normal c functional ffi call *) @@ -88401,7 +88434,7 @@ let check_ffi ?loc ffi = | Js_set name | Js_get name -> valid_method_name ?loc name - | Obj_create _ -> () + (* | Obj_create _ -> () *) | Js_get_index | Js_set_index -> () @@ -88628,7 +88661,9 @@ end = struct module E = Js_exp_make module S = Js_stmt_make -let eval (arg : J.expression) (dispatches : (int * string) list ) = +(* we need destruct [undefined] when input is optional *) +let eval (arg : J.expression) (dispatches : (int * string) list ) : E.t = + if arg == E.undefined then E.undefined else match arg.expression_desc with | Number (Int {i} | Uint i) -> begin match List.assoc (Int32.to_int i) dispatches with @@ -88645,7 +88680,8 @@ let eval (arg : J.expression) (dispatches : (int * string) list ) = false (* FIXME: if true, still print break*) }) dispatches))] -let eval_as_event (arg : J.expression) (dispatches : (int * string) list ) = +(** invariant: optional is not allowed in this case *) +let eval_as_event (arg : J.expression) (dispatches : (int * string) list ) : E.t list = match arg.expression_desc with | Array ([{expression_desc = Number (Int {i} | Uint i)}; cb], _) | Caml_block([{expression_desc = Number (Int {i} | Uint i)}; cb], _, _, _) @@ -88678,7 +88714,9 @@ let eval_as_event (arg : J.expression) (dispatches : (int * string) list ) = }) dispatches))] ] -let eval_as_int (arg : J.expression) (dispatches : (int * int) list ) = +(* we need destruct [undefined] when input is optional *) +let eval_as_int (arg : J.expression) (dispatches : (int * int) list ) : E.t = + if arg == E.undefined then E.undefined else match arg.expression_desc with | Number (Int {i} | Uint i) -> begin match (List.assoc (Int32.to_int i) dispatches) with @@ -89994,13 +90032,39 @@ let handle_external_opt type typ = Ast_core_type.t +(** The first return value is value, the second argument is side effect expressions + Only the [unit] with no label will be ignored + When we are passing a boxed value to external(optional), we need + unbox it in the first place. + + Note when optional value is not passed, the unboxed value would be + [undefined], with the combination of `[@bs.int]` it would be still be + [undefined], this by default is still correct.. + {[ + (function () { + switch (undefined) { + case 97 : + return "a"; + case 98 : + return "b"; + + } + }()) === undefined + ]} -let ocaml_to_js_eff ({ Ast_ffi_types.arg_label; arg_type = ty }) + This would not work with [NonNullString] +*) +let ocaml_to_js_eff + ({ Ast_ffi_types.arg_label; arg_type }) (arg : J.expression) : E.t list * E.t list = - match ty with - | Unit -> - [], + let arg = + match arg_label with + | Optional label -> Js_of_lam_option.get_default_undefined arg + | Label _ | Empty -> arg in + match arg_type with + | Extern_unit -> + (if arg_label = Empty then [] else [E.unit]), (if Js_analyzer.no_side_effect_expression arg then [] else @@ -90017,14 +90081,13 @@ let ocaml_to_js_eff ({ Ast_ffi_types.arg_label; arg_type = ty }) Js_of_lam_variant.eval_as_event arg dispatches,[] | Int dispatches -> [Js_of_lam_variant.eval_as_int arg dispatches],[] - | Nothing | Array -> - begin match arg_label with - | Optional label -> [Js_of_lam_option.get_default_undefined arg] - | Label _ | Empty -> [arg] - end, [] + | Nothing | Array -> [arg], [] +let fuse x xs = + if xs = [] then x + else List.fold_left E.seq x xs -let assemble_args arg_types args : E.t list * E.t option = +let assemble_args (arg_types : Ast_ffi_types.arg_kind list) args : E.t list * E.t option = let args, eff = List.fold_right2 (fun arg_type arg (accs, effs) -> @@ -90034,7 +90097,7 @@ let assemble_args arg_types args : E.t list * E.t option = ) arg_types args ([],[]) in args, begin match eff with | [] -> None - | x::xs -> Some (List.fold_left (fun x y -> E.seq x y) x xs ) + | x::xs -> Some (fuse x xs) end let add_eff eff e = @@ -90052,30 +90115,41 @@ let add_eff eff e = ]} But the default to be undefined seems reasonable *) -let assemble_args_obj labels args = +let assemble_args_obj (labels : Ast_ffi_types.arg_kind list) (args : J.expression list) = + let map, eff = List.fold_right2 - (fun label ( arg : J.expression) (accs, eff ) -> - match (label : Ast_core_type.arg_label) with + (fun ({arg_label; arg_type} as arg_kind : Ast_ffi_types.arg_kind) ( arg : J.expression) (accs, eff ) -> + match arg_label with | Empty -> accs , if Js_analyzer.no_side_effect_expression arg then eff else arg :: eff | Label label -> - ( Js_op.Key label, arg) :: accs, eff + let acc, new_eff = ocaml_to_js_eff arg_kind arg in + begin match acc with + | [ ] -> assert false + | x::xs -> + (Js_op.Key label, fuse x xs ) :: accs , new_eff @ eff + end (* evaluation order is undefined *) | Optional label -> begin match arg.expression_desc with | Number _ -> (*Invariant: None encoding*) accs, eff - | _ -> - ( Js_op.Key label, Js_of_lam_option.get_default_undefined arg) :: accs, - eff + | _ -> + let acc, new_eff = ocaml_to_js_eff arg_kind arg in + begin match acc with + | [] -> assert false + | x::xs -> + (Js_op.Key label, fuse x xs)::accs , + new_eff @ eff + end end ) labels args ([], []) in match eff with | [] -> E.obj map - | x::xs -> E.seq (List.fold_left (fun x y -> E.seq x y) x xs) (E.obj map) + | x::xs -> E.seq (fuse x xs) (E.obj map) (* TODO: fix splice, @@ -90112,7 +90186,8 @@ let assemble_args_splice call_loc ffi js_splice arg_types args : E.t list * E.t args, begin match eff with | [] -> None - | x::xs -> Some (List.fold_left (fun x y -> E.seq x y) x xs) + | x::xs -> + Some (fuse x xs) end @@ -90121,7 +90196,7 @@ let translate_ffi call_loc (ffi : Ast_ffi_types.ffi ) prim_name arg_types result_type (args : J.expression list) = match ffi with - | Obj_create labels -> assemble_args_obj labels args + | Js_call{ external_module_name = module_name; name = fn; splice = js_splice ; @@ -90136,10 +90211,10 @@ let translate_ffi call_loc (ffi : Ast_ffi_types.ffi ) prim_name add_eff eff (if result_type then - E.seq (E.call ~info:{arity=Full; call_info = Call_na} fn args) E.unit - else - E.call ~info:{arity=Full; call_info = Call_na} fn args) - + E.seq (E.call ~info:{arity=Full; call_info = Call_na} fn args) E.unit + else + E.call ~info:{arity=Full; call_info = Call_na} fn args) + | Js_module_as_var module_name -> let (id, name) = handle_external module_name in E.external_var_dot id ~external_name:name @@ -90286,6 +90361,7 @@ let translate loc cxt match Ast_ffi_types.from_string prim_native_name with | Ffi_normal -> Lam_dispatch_primitive.translate prim_name args + | Ffi_obj_create labels -> assemble_args_obj labels args | Ffi_bs (arg_types, result_type, ffi) -> translate_ffi loc ffi prim_name cxt arg_types result_type args @@ -96117,8 +96193,7 @@ let compile ~filename output_prefix env _sigs let export_ident_sets = Ident_set.of_list export_idents in (* To make toplevel happy - reentrant for js-demo *) let () = - export_idents |> List.iter - (fun (id : Ident.t) -> Ext_log.dwarn __LOC__ "export: %s/%d" id.name id.stamp) ; + Lam_compile_env.reset () ; in let lam = Lam.convert export_ident_sets lam in @@ -98428,10 +98503,11 @@ end = struct ]} The result type would be [ hi:string ] *) -let get_arg_type - ({ptyp_desc; ptyp_attributes; ptyp_loc = loc} as ptyp : Ast_core_type.t) : +let get_arg_type ~nolabel optional + (ptyp : Ast_core_type.t) : Ast_core_type.arg_type * Ast_core_type.t = - match Ast_attributes.process_bs_string_int ptyp_attributes, ptyp_desc with + let ptyp = if optional then Ast_core_type.extract_option_type_exn ptyp else ptyp in + match Ast_attributes.process_bs_string_int ptyp.ptyp_attributes, ptyp.ptyp_desc with | (`String, ptyp_attributes), Ptyp_variant ( row_fields, Closed, None) -> let case, result, row_fields = @@ -98459,16 +98535,16 @@ let get_arg_type `NonNull, ((Ext_pervasives.hash_variant label, label) :: acc), (tag :: row_fields) end - | _ -> Location.raise_errorf ~loc "Not a valid string type" + | _ -> Location.raise_errorf ~loc:ptyp.ptyp_loc "Not a valid string type" ) row_fields (`Nothing, [], [])) in (match case with - | `Nothing -> Location.raise_errorf ~loc "Not a valid string type" + | `Nothing -> Location.raise_errorf ~loc:ptyp.ptyp_loc "Not a valid string type" | `Null -> NullString result | `NonNull -> NonNullString result) , {ptyp with ptyp_desc = Ptyp_variant(row_fields, Closed, None); ptyp_attributes ; } - | (`String, _), _ -> Location.raise_errorf ~loc "Not a valid string type" + | (`String, _), _ -> Location.raise_errorf ~loc:ptyp.ptyp_loc "Not a valid string type" | (`Ignore, ptyp_attributes), _ -> (Ignore, {ptyp with ptyp_attributes}) @@ -98487,7 +98563,7 @@ let get_arg_type i + 1 , ((Ext_pervasives.hash_variant label , i):: acc ), rtag::row_fields end - | _ -> Location.raise_errorf ~loc "Not a valid string type" + | _ -> Location.raise_errorf ~loc:ptyp.ptyp_loc "Not a valid string type" ) (0, [],[]) row_fields) in Int (List.rev acc), {ptyp with @@ -98495,19 +98571,19 @@ let get_arg_type ptyp_attributes } - | (`Int, _), _ -> Location.raise_errorf ~loc "Not a valid string type" + | (`Int, _), _ -> Location.raise_errorf ~loc:ptyp.ptyp_loc "Not a valid string type" | (`Nothing, ptyp_attributes), ptyp_desc -> begin match ptyp_desc with | Ptyp_constr ({txt = Lident "bool"}, []) -> - Bs_warnings.prerr_warning loc Unsafe_ffi_bool_type; + Bs_warnings.prerr_warning ptyp.ptyp_loc Unsafe_ffi_bool_type; Nothing | Ptyp_constr ({txt = Lident "unit"}, []) - -> Unit + -> if nolabel then Extern_unit else Nothing | Ptyp_constr ({txt = Lident "array"}, [_]) -> Array | Ptyp_variant _ -> - Bs_warnings.prerr_warning loc Unsafe_poly_variant_type; + Bs_warnings.prerr_warning ptyp.ptyp_loc Unsafe_poly_variant_type; Nothing | _ -> Nothing @@ -98643,7 +98719,7 @@ let process_external_attributes (init_st, []) prim_attributes -let list_of_arrow_clean_option_label (ty : Parsetree.core_type) = +let list_of_arrow (ty : Parsetree.core_type) = let rec aux (ty : Parsetree.core_type) acc = match ty.ptyp_desc with | Ptyp_arrow(label,t1,t2) -> @@ -98653,6 +98729,7 @@ let list_of_arrow_clean_option_label (ty : Parsetree.core_type) = | return_type -> ty, List.rev acc in aux ty [] + (** Note that the passed [type_annotation] is already processed by visitor pattern before *) let handle_attributes @@ -98666,43 +98743,18 @@ let handle_attributes else `Nm_external prim_name (* need check name *) in let result_type, arg_types_ty = - list_of_arrow_clean_option_label type_annotation in + list_of_arrow type_annotation in let result_type_spec, new_result_type = - get_arg_type result_type in + get_arg_type ~nolabel:true false result_type in (* result type can not be labeled *) let (st, left_attrs) = process_external_attributes (arg_types_ty = []) prim_name_or_pval_prim pval_prim prim_attributes in - let splice = st.splice in - let arg_type_specs, new_arg_types_ty, arg_type_specs_length = - List.fold_right - (fun (label,ty,attr,loc) (arg_type_specs, arg_types, i) -> - let arg_type, new_ty = get_arg_type ty in - (if i = 0 && splice then - match arg_type with - | Array -> () - | _ -> Location.raise_errorf ~loc "[@@bs.splice] expect last type to array"); - ({ Ast_ffi_types.arg_label = Ast_core_type.label_name label ; - arg_type - } :: arg_type_specs, - (label, new_ty,attr,loc) :: arg_types, - i + 1) - ) arg_types_ty - (match st with - | {val_send_pipe = Some obj} -> - let arg_type, new_ty = get_arg_type obj in - [{ arg_label = Empty ; - arg_type - }], - ["", new_ty, [], obj.ptyp_loc] - ,0 - | {val_send_pipe = None } -> [],[], 0) in - - - let ffi = - match st with - | { mk_obj = true; + + if st.mk_obj then + begin match st with + | { val_name = `Nm_na; external_module_name = None ; module_as_val = None; @@ -98714,314 +98766,385 @@ let handle_attributes set_name = `Nm_na ; get_name = `Nm_na ; get_index = false ; - } -> - if String.length prim_name <> 0 then - Location.raise_errorf ~loc "[@@bs.obj] expect external names to be empty string"; - Ast_ffi_types.Obj_create (List.map (function - | {Ast_ffi_types.arg_label = (Empty as l) ; arg_type = Unit } - -> l - | {arg_label = Empty ; arg_type = _ } - -> Location.raise_errorf ~loc "expect label, optional, or unit here" - | {arg_label = (Label _) ; arg_type = (Ignore | Unit) ; } - -> Empty - | {arg_label = Label name ; arg_type = (Nothing | Array)} -> - Label (Lam_methname.translate ~loc name) - | {arg_label = Label l ; arg_type = (NullString _ | NonNullString _ | Int _ ) } - -> Location.raise_errorf ~loc - "bs.obj label %s does not support such arg type" l - | {arg_label = Optional name ; arg_type = (Nothing | Array | Unit | Ignore)} - -> Optional (Lam_methname.translate ~loc name) - | {arg_label = Optional l ; arg_type = (NullString _ | NonNullString _ | Int _)} - -> Location.raise_errorf ~loc - "bs.obj optional %s does not support such arg type" l ) - arg_type_specs)(* Need fetch label here, for better error message *) - | {mk_obj = true; _} - -> - Location.raise_errorf ~loc "conflict attributes found" - | {set_index = true; - - val_name = `Nm_na; - external_module_name = None ; - module_as_val = None; - val_send = `Nm_na; - val_send_pipe = None; - splice = false; - get_index = false; - new_name = `Nm_na; - call_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - mk_obj = false ; + } -> + if String.length prim_name <> 0 then + Location.raise_errorf ~loc "[@@bs.obj] expect external names to be empty string"; + let arg_kinds, new_arg_types_ty, result_types = + List.fold_right + (fun (label,ty,attr,loc) ( arg_labels, arg_types, result_types) -> + let arg_label = Ast_core_type.label_name label in + let new_arg_label, new_ty, output_tys = + match arg_label with + | Empty -> + let arg_type, new_ty = get_arg_type ~nolabel:true false ty in + begin match arg_type with + | Extern_unit -> { Ast_ffi_types. arg_label; arg_type }, new_ty, result_types + | _ -> + Location.raise_errorf ~loc "expect label, optional, or unit here" + end + | Label name -> + let arg_type, new_ty = get_arg_type ~nolabel:false false ty in + begin match arg_type with + | Ignore -> { arg_label = Empty ; arg_type }, new_ty, result_types + + | Nothing | Array -> + let s = (Lam_methname.translate ~loc name) in + {arg_label = Label s ; arg_type }, new_ty, + ((name , [], new_ty) :: result_types) + | Int _ -> + let s = Lam_methname.translate ~loc name in + {arg_label = Label s; arg_type}, new_ty, ((name, [], Ast_literal.type_int ~loc ()) :: result_types) + | NullString _ -> + let s = Lam_methname.translate ~loc name in + {arg_label = Label s; arg_type}, new_ty, + ((name, [], Ast_literal.type_string ~loc ()) :: result_types) + | Extern_unit -> assert false + | NonNullString _ + -> + Location.raise_errorf ~loc + "bs.obj label %s does not support such arg type" name + end + | Optional name -> + let arg_type, new_ty_extract = get_arg_type ~nolabel:false true ty in + let new_ty = Ast_core_type.lift_option_type new_ty_extract in + begin match arg_type with + | Ignore -> + {arg_label = Empty ; arg_type}, new_ty, result_types + + | Nothing | Array -> + let s = (Lam_methname.translate ~loc name) in + {arg_label = Optional s; arg_type}, new_ty, + ( (name, [], Ast_comb.to_undefined_type loc new_ty_extract) :: result_types) + | Int _ -> + let s = Lam_methname.translate ~loc name in + {arg_label = Optional s ; arg_type }, new_ty, + ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_int ~loc ()) :: result_types) + | NullString _ -> + let s = Lam_methname.translate ~loc name in + {arg_label = Optional s ; arg_type }, new_ty, + ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_string ~loc ()) :: result_types) + | Extern_unit -> assert false + | NonNullString _ + -> + Location.raise_errorf ~loc + "bs.obj label %s does not support such arg type" name + end + in + ( + new_arg_label::arg_labels, + (label, new_ty,attr,loc) :: arg_types, + output_tys)) arg_types_ty + ( [], [], []) in + let result = + if Ast_core_type.is_any new_result_type then + Ast_core_type.make_obj ~loc result_types + else new_result_type + in + begin + ( + List.fold_right (fun (label,ty,attrs,loc) acc -> + Ast_helper.Typ.arrow ~loc ~attrs label ty acc + ) new_arg_types_ty result + ) , + prim_name, + Ffi_obj_create arg_kinds, + left_attrs + end - } - -> - if String.length prim_name <> 0 then - Location.raise_errorf ~loc "[@@bs.set_index] expect external names to be empty string"; - if arg_type_specs_length = 3 then - Js_set_index - else - Location.raise_errorf ~loc "Ill defined attribute [@@bs.set_index](arity of 3)" + | _ -> Location.raise_errorf ~loc "conflict attributes found [@@bs.obj]" - | {set_index = true; _} - -> - Location.raise_errorf ~loc "conflict attributes found" - - | {get_index = true; - - val_name = `Nm_na; - external_module_name = None ; - module_as_val = None; - val_send = `Nm_na; - val_send_pipe = None; - - splice = false; - new_name = `Nm_na; - call_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - mk_obj = false ; - } -> - if String.length prim_name <> 0 then - Location.raise_errorf ~loc "[@@bs.get_index] expect external names to be empty string"; - if arg_type_specs_length = 2 then - Js_get_index - else Location.raise_errorf ~loc "Ill defined attribute [@@bs.get_index] (arity of 2)" - - | {get_index = true; _} - -> Location.raise_errorf ~loc "conflict attributes found" - - - (*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] ]} - *) - | {module_as_val = Some external_module_name ; - - get_index = false; - val_name ; - new_name ; - - external_module_name = None ; - val_send = `Nm_na; - val_send_pipe = None; - splice ; - call_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - mk_obj = false ;} -> - begin match arg_types_ty, new_name, val_name with - | [], `Nm_na, _ -> Js_module_as_var external_module_name - | _, `Nm_na, _ -> Js_module_as_fn {splice; external_module_name } - | _, #bundle_source, #bundle_source -> - Location.raise_errorf ~loc "conflict attributes found" - | _, (`Nm_val _ | `Nm_external _) , `Nm_na - -> Js_module_as_class external_module_name - | _, `Nm_payload _ , `Nm_na - -> - Location.raise_errorf ~loc - "conflict attributes found: (bs.new should not carry payload here)" + end - end - | {module_as_val = Some _} - -> Location.raise_errorf ~loc "conflict attributes found" - | {call_name = (`Nm_val name | `Nm_external name | `Nm_payload name) ; - splice; - external_module_name; - - val_name = `Nm_na ; - module_as_val = None; - val_send = `Nm_na ; - val_send_pipe = None; - - set_index = false; - get_index = false; - new_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na - } -> - Js_call {splice; name; external_module_name} - | {call_name = #bundle_source } - -> Location.raise_errorf ~loc "conflict attributes found" - - | {val_name = (`Nm_val name | `Nm_external name | `Nm_payload name); - external_module_name; - - call_name = `Nm_na ; - module_as_val = None; - val_send = `Nm_na ; - val_send_pipe = None; - set_index = false; - get_index = false; - new_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na + else + let splice = st.splice in + let arg_type_specs, new_arg_types_ty, arg_type_specs_length = + List.fold_right + (fun (label,ty,attr,loc) (arg_type_specs, arg_types, i) -> + let arg_label = Ast_core_type.label_name label in + let arg_type, new_ty = + match arg_label with + | Optional _ -> + + let arg_type , new_ty = get_arg_type ~nolabel:false true ty in + begin match arg_type with + | NonNullString _ -> + (* ?x:([`x of int ] [@bs.string]) does not make sense *) + Location.raise_errorf + ~loc + "[@@bs.string] does not work with optional when it has arities in label %s" label + | _ -> + arg_type, Ast_core_type.lift_option_type new_ty end + | Label _ | Empty -> + get_arg_type ~nolabel:(arg_label = Empty) false ty in + (if i = 0 && splice then + match arg_type with + | Array -> () + | _ -> Location.raise_errorf ~loc "[@@bs.splice] expect last type to array"); + ({ Ast_ffi_types.arg_label ; + arg_type + } :: arg_type_specs, + (label, new_ty,attr,loc) :: arg_types, + i + 1) + ) arg_types_ty + (match st with + | {val_send_pipe = Some obj} -> + let arg_type, new_ty = get_arg_type ~nolabel:true false obj in + [{ arg_label = Empty ; + arg_type + }], + ["", new_ty, [], obj.ptyp_loc] + ,0 + | {val_send_pipe = None } -> [],[], 0) in + + let ffi : Ast_ffi_types.ffi = match st with + | {set_index = true; + + val_name = `Nm_na; + external_module_name = None ; + module_as_val = None; + val_send = `Nm_na; + val_send_pipe = None; + splice = false; + get_index = false; + new_name = `Nm_na; + call_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + } + -> + if String.length prim_name <> 0 then + Location.raise_errorf ~loc "[@@bs.set_index] expect external names to be empty string"; + if arg_type_specs_length = 3 then + Js_set_index + else + Location.raise_errorf ~loc "Ill defined attribute [@@bs.set_index](arity of 3)" - } - -> - Js_global { name; external_module_name} - | {val_name = #bundle_source } - -> Location.raise_errorf ~loc "conflict attributes found" - | {splice ; - external_module_name = (Some _ as external_module_name); - - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - val_send = `Nm_na ; - val_send_pipe = None; - set_index = false; - get_index = false; - new_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; + | {set_index = true; _} + -> + Location.raise_errorf ~loc "conflict attributes found" + + | {get_index = true; + + val_name = `Nm_na; + external_module_name = None ; + module_as_val = None; + val_send = `Nm_na; + val_send_pipe = None; + + splice = false; + new_name = `Nm_na; + call_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + } -> + if String.length prim_name <> 0 then + Location.raise_errorf ~loc "[@@bs.get_index] expect external names to be empty string"; + if arg_type_specs_length = 2 then + Js_get_index + else Location.raise_errorf ~loc "Ill defined attribute [@@bs.get_index] (arity of 2)" + + | {get_index = true; _} + -> Location.raise_errorf ~loc "conflict attributes found" + + + + | {module_as_val = Some external_module_name ; + + get_index = false; + val_name ; + new_name ; + + external_module_name = None ; + val_send = `Nm_na; + val_send_pipe = None; + splice ; + call_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + mk_obj = false ;} -> + begin match arg_types_ty, new_name, val_name with + | [], `Nm_na, _ -> Js_module_as_var external_module_name + | _, `Nm_na, _ -> Js_module_as_fn {splice; external_module_name } + | _, #bundle_source, #bundle_source -> + Location.raise_errorf ~loc "conflict attributes found" + | _, (`Nm_val _ | `Nm_external _) , `Nm_na + -> Js_module_as_class external_module_name + | _, `Nm_payload _ , `Nm_na + -> + Location.raise_errorf ~loc + "conflict attributes found: (bs.new should not carry payload here)" - } - -> - let name = string_of_bundle_source prim_name_or_pval_prim in - if arg_type_specs_length = 0 then + end + | {module_as_val = Some _} + -> Location.raise_errorf ~loc "conflict attributes found" + | {call_name = (`Nm_val name | `Nm_external name | `Nm_payload name) ; + splice; + external_module_name; + + val_name = `Nm_na ; + module_as_val = None; + val_send = `Nm_na ; + val_send_pipe = None; + + set_index = false; + get_index = false; + new_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na + } -> + Js_call {splice; name; external_module_name} + | {call_name = #bundle_source } + -> Location.raise_errorf ~loc "conflict attributes found" + + | {val_name = (`Nm_val name | `Nm_external name | `Nm_payload name); + external_module_name; + + call_name = `Nm_na ; + module_as_val = None; + val_send = `Nm_na ; + val_send_pipe = None; + set_index = false; + get_index = false; + new_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na + + } + -> Js_global { name; external_module_name} - else Js_call {splice; name; external_module_name} - | {val_send = (`Nm_val name | `Nm_external name | `Nm_payload name); - splice; - val_send_pipe = None; - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - set_index = false; - get_index = false; - new_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - external_module_name = None ; - } -> - if arg_type_specs_length > 0 then - Js_send {splice ; name; pipe = false} - else - Location.raise_errorf ~loc "Ill defined attribute [@@bs.send] (at least one argument)" - | {val_send = #bundle_source} - -> Location.raise_errorf ~loc "conflict attributes found" - - | {val_send_pipe = Some typ; - (* splice = (false as splice); *) - val_send = `Nm_na; - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - set_index = false; - get_index = false; - new_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - external_module_name = None ; - } -> - (** can be one argument *) - Js_send {splice ; - name = string_of_bundle_source prim_name_or_pval_prim; - pipe = true} - - | {val_send_pipe = Some _ } - -> Location.raise_errorf ~loc "conflict attributes found" - - | {new_name = (`Nm_val name | `Nm_external name | `Nm_payload name); - external_module_name; - - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - set_index = false; - get_index = false; - val_send = `Nm_na ; - val_send_pipe = None; - set_name = `Nm_na ; - get_name = `Nm_na ; - splice - } - -> Js_new {name; external_module_name; splice} - | {new_name = #bundle_source } - -> Location.raise_errorf ~loc "conflict attributes found" - - | {set_name = (`Nm_val name | `Nm_external name | `Nm_payload name); - - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - set_index = false; - get_index = false; - val_send = `Nm_na ; - val_send_pipe = None; - new_name = `Nm_na ; - get_name = `Nm_na ; - external_module_name = None - } - -> - if arg_type_specs_length = 2 then - Js_set name - else Location.raise_errorf ~loc "Ill defined attribute [@@bs.set] (two args required)" - - | {set_name = #bundle_source} - -> Location.raise_errorf ~loc "conflict attributes found" - - | {get_name = (`Nm_val name | `Nm_external name | `Nm_payload name); - - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - set_index = false; - get_index = false; - val_send = `Nm_na ; - val_send_pipe = None; - new_name = `Nm_na ; - set_name = `Nm_na ; - external_module_name = None - } - -> - if arg_type_specs_length = 1 then - Js_get name - else - Location.raise_errorf ~loc "Ill defined attribute [@@bs.get] (only one argument)" - | {get_name = #bundle_source} - -> Location.raise_errorf ~loc "conflict attributes found" - | _ -> Location.raise_errorf ~loc "Illegal attribute found" in - begin - Ast_ffi_types.check_ffi ~loc ffi; - (match ffi, new_result_type with - | Obj_create arg_labels , {ptyp_desc = Ptyp_any; _} - -> - (* special case: - {[ external f : int -> string -> _ = "" ]} - *) - let result = - Ast_core_type.make_obj ~loc ( - List.fold_right2 - (fun arg (label : Ast_core_type.arg_label) acc -> - match arg, label with - | (_, ty, _,_), Label s - -> (s , [], ty) :: acc - | (_, ty, _,_), Optional s - -> - (s, [], - Ast_comb.to_undefined_type loc @@ - Ast_core_type.extract_option_type_exn ty - ) :: acc - | (_, _, _,_), Empty -> acc - ) arg_types_ty arg_labels []) in - - List.fold_right (fun (label,ty,attrs,loc) acc -> - Ast_helper.Typ.arrow ~loc ~attrs label ty acc - ) new_arg_types_ty result - - (* Ast_core_type.replace_result type_annotation result *) - | _ -> - List.fold_right (fun (label,ty,attrs,loc) acc -> - Ast_helper.Typ.arrow ~loc ~attrs label ty acc - ) new_arg_types_ty new_result_type - ) , - prim_name, - (Ffi_bs (arg_type_specs, result_type_spec = Unit , ffi)), left_attrs - end + | {val_name = #bundle_source } + -> Location.raise_errorf ~loc "conflict attributes found" + | {splice ; + external_module_name = (Some _ as external_module_name); + + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + val_send = `Nm_na ; + val_send_pipe = None; + set_index = false; + get_index = false; + new_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + + } + -> + let name = string_of_bundle_source prim_name_or_pval_prim in + if arg_type_specs_length = 0 then + Js_global { name; external_module_name} + else Js_call {splice; name; external_module_name} + | {val_send = (`Nm_val name | `Nm_external name | `Nm_payload name); + splice; + val_send_pipe = None; + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + set_index = false; + get_index = false; + new_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + external_module_name = None ; + } -> + if arg_type_specs_length > 0 then + Js_send {splice ; name; pipe = false} + else + Location.raise_errorf ~loc "Ill defined attribute [@@bs.send] (at least one argument)" + | {val_send = #bundle_source} + -> Location.raise_errorf ~loc "conflict attributes found" + + | {val_send_pipe = Some typ; + (* splice = (false as splice); *) + val_send = `Nm_na; + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + set_index = false; + get_index = false; + new_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + external_module_name = None ; + } -> + (** can be one argument *) + Js_send {splice ; + name = string_of_bundle_source prim_name_or_pval_prim; + pipe = true} + + | {val_send_pipe = Some _ } + -> Location.raise_errorf ~loc "conflict attributes found" + + | {new_name = (`Nm_val name | `Nm_external name | `Nm_payload name); + external_module_name; + + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + set_index = false; + get_index = false; + val_send = `Nm_na ; + val_send_pipe = None; + set_name = `Nm_na ; + get_name = `Nm_na ; + splice + } + -> Js_new {name; external_module_name; splice} + | {new_name = #bundle_source } + -> Location.raise_errorf ~loc "conflict attributes found" + + | {set_name = (`Nm_val name | `Nm_external name | `Nm_payload name); + + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + set_index = false; + get_index = false; + val_send = `Nm_na ; + val_send_pipe = None; + new_name = `Nm_na ; + get_name = `Nm_na ; + external_module_name = None + } + -> + if arg_type_specs_length = 2 then + Js_set name + else Location.raise_errorf ~loc "Ill defined attribute [@@bs.set] (two args required)" + + | {set_name = #bundle_source} + -> Location.raise_errorf ~loc "conflict attributes found" + + | {get_name = (`Nm_val name | `Nm_external name | `Nm_payload name); + + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + set_index = false; + get_index = false; + val_send = `Nm_na ; + val_send_pipe = None; + new_name = `Nm_na ; + set_name = `Nm_na ; + external_module_name = None + } + -> + if arg_type_specs_length = 1 then + Js_get name + else + Location.raise_errorf ~loc "Ill defined attribute [@@bs.get] (only one argument)" + | {get_name = #bundle_source} + -> Location.raise_errorf ~loc "conflict attributes found" + | _ -> Location.raise_errorf ~loc "Illegal attribute found" in + begin + Ast_ffi_types.check_ffi ~loc ffi; + ( + List.fold_right (fun (label,ty,attrs,loc) acc -> + Ast_helper.Typ.arrow ~loc ~attrs label ty acc + ) new_arg_types_ty new_result_type + ) , + prim_name, + (Ffi_bs (arg_type_specs, result_type_spec = Extern_unit , ffi)), left_attrs + end let handle_attributes_as_string pval_loc @@ -99033,17 +99156,17 @@ let handle_attributes_as_string let pval_prim_of_labels labels = let encoding = - let (arg_kinds, vs) = + let arg_kinds = List.fold_right - (fun {Asttypes.loc ; txt } (arg_kinds,v) + (fun {Asttypes.loc ; txt } arg_kinds -> let arg_label = Ast_core_type.Label (Lam_methname.translate ~loc txt) in {Ast_ffi_types.arg_type = Nothing ; - arg_label } :: arg_kinds, arg_label :: v + arg_label } :: arg_kinds ) - labels ([],[]) in - Ast_ffi_types.to_string @@ - Ffi_bs (arg_kinds , false, Obj_create vs) in + labels [] in + Ast_ffi_types.to_string + (Ffi_obj_create arg_kinds) in [""; encoding] diff --git a/jscomp/core/js_exp_make.ml b/jscomp/core/js_exp_make.ml index a0c7d80b9d..a386233876 100644 --- a/jscomp/core/js_exp_make.ml +++ b/jscomp/core/js_exp_make.ml @@ -357,6 +357,8 @@ let dot ?comment (e0 : t) (e1 : string) : t = let undefined = var Ext_ident.undefined + + let nil = var Ext_ident.nil (** coupled with the runtime *) diff --git a/jscomp/core/js_of_lam_variant.ml b/jscomp/core/js_of_lam_variant.ml index 4791b5289c..41466a0056 100644 --- a/jscomp/core/js_of_lam_variant.ml +++ b/jscomp/core/js_of_lam_variant.ml @@ -25,7 +25,9 @@ module E = Js_exp_make module S = Js_stmt_make -let eval (arg : J.expression) (dispatches : (int * string) list ) = +(* we need destruct [undefined] when input is optional *) +let eval (arg : J.expression) (dispatches : (int * string) list ) : E.t = + if arg == E.undefined then E.undefined else match arg.expression_desc with | Number (Int {i} | Uint i) -> begin match List.assoc (Int32.to_int i) dispatches with @@ -42,7 +44,8 @@ let eval (arg : J.expression) (dispatches : (int * string) list ) = false (* FIXME: if true, still print break*) }) dispatches))] -let eval_as_event (arg : J.expression) (dispatches : (int * string) list ) = +(** invariant: optional is not allowed in this case *) +let eval_as_event (arg : J.expression) (dispatches : (int * string) list ) : E.t list = match arg.expression_desc with | Array ([{expression_desc = Number (Int {i} | Uint i)}; cb], _) | Caml_block([{expression_desc = Number (Int {i} | Uint i)}; cb], _, _, _) @@ -75,7 +78,9 @@ let eval_as_event (arg : J.expression) (dispatches : (int * string) list ) = }) dispatches))] ] -let eval_as_int (arg : J.expression) (dispatches : (int * int) list ) = +(* we need destruct [undefined] when input is optional *) +let eval_as_int (arg : J.expression) (dispatches : (int * int) list ) : E.t = + if arg == E.undefined then E.undefined else match arg.expression_desc with | Number (Int {i} | Uint i) -> begin match (List.assoc (Int32.to_int i) dispatches) with diff --git a/jscomp/core/lam_compile_external_call.ml b/jscomp/core/lam_compile_external_call.ml index 93d7978db1..ce5fac7893 100644 --- a/jscomp/core/lam_compile_external_call.ml +++ b/jscomp/core/lam_compile_external_call.ml @@ -55,13 +55,39 @@ let handle_external_opt type typ = Ast_core_type.t - -let ocaml_to_js_eff ({ Ast_ffi_types.arg_label; arg_type = ty }) +(** The first return value is value, the second argument is side effect expressions + Only the [unit] with no label will be ignored + When we are passing a boxed value to external(optional), we need + unbox it in the first place. + + Note when optional value is not passed, the unboxed value would be + [undefined], with the combination of `[@bs.int]` it would be still be + [undefined], this by default is still correct.. + {[ + (function () { + switch (undefined) { + case 97 : + return "a"; + case 98 : + return "b"; + + } + }()) === undefined + ]} + + This would not work with [NonNullString] +*) +let ocaml_to_js_eff + ({ Ast_ffi_types.arg_label; arg_type }) (arg : J.expression) : E.t list * E.t list = - match ty with - | Unit -> - [], + let arg = + match arg_label with + | Optional label -> Js_of_lam_option.get_default_undefined arg + | Label _ | Empty -> arg in + match arg_type with + | Extern_unit -> + (if arg_label = Empty then [] else [E.unit]), (if Js_analyzer.no_side_effect_expression arg then [] else @@ -78,14 +104,13 @@ let ocaml_to_js_eff ({ Ast_ffi_types.arg_label; arg_type = ty }) Js_of_lam_variant.eval_as_event arg dispatches,[] | Int dispatches -> [Js_of_lam_variant.eval_as_int arg dispatches],[] - | Nothing | Array -> - begin match arg_label with - | Optional label -> [Js_of_lam_option.get_default_undefined arg] - | Label _ | Empty -> [arg] - end, [] + | Nothing | Array -> [arg], [] +let fuse x xs = + if xs = [] then x + else List.fold_left E.seq x xs -let assemble_args arg_types args : E.t list * E.t option = +let assemble_args (arg_types : Ast_ffi_types.arg_kind list) args : E.t list * E.t option = let args, eff = List.fold_right2 (fun arg_type arg (accs, effs) -> @@ -95,7 +120,7 @@ let assemble_args arg_types args : E.t list * E.t option = ) arg_types args ([],[]) in args, begin match eff with | [] -> None - | x::xs -> Some (List.fold_left (fun x y -> E.seq x y) x xs ) + | x::xs -> Some (fuse x xs) end let add_eff eff e = @@ -113,30 +138,41 @@ let add_eff eff e = ]} But the default to be undefined seems reasonable *) -let assemble_args_obj labels args = +let assemble_args_obj (labels : Ast_ffi_types.arg_kind list) (args : J.expression list) = + let map, eff = List.fold_right2 - (fun label ( arg : J.expression) (accs, eff ) -> - match (label : Ast_core_type.arg_label) with + (fun ({arg_label; arg_type} as arg_kind : Ast_ffi_types.arg_kind) ( arg : J.expression) (accs, eff ) -> + match arg_label with | Empty -> accs , if Js_analyzer.no_side_effect_expression arg then eff else arg :: eff | Label label -> - ( Js_op.Key label, arg) :: accs, eff + let acc, new_eff = ocaml_to_js_eff arg_kind arg in + begin match acc with + | [ ] -> assert false + | x::xs -> + (Js_op.Key label, fuse x xs ) :: accs , new_eff @ eff + end (* evaluation order is undefined *) | Optional label -> begin match arg.expression_desc with | Number _ -> (*Invariant: None encoding*) accs, eff - | _ -> - ( Js_op.Key label, Js_of_lam_option.get_default_undefined arg) :: accs, - eff + | _ -> + let acc, new_eff = ocaml_to_js_eff arg_kind arg in + begin match acc with + | [] -> assert false + | x::xs -> + (Js_op.Key label, fuse x xs)::accs , + new_eff @ eff + end end ) labels args ([], []) in match eff with | [] -> E.obj map - | x::xs -> E.seq (List.fold_left (fun x y -> E.seq x y) x xs) (E.obj map) + | x::xs -> E.seq (fuse x xs) (E.obj map) (* TODO: fix splice, @@ -173,7 +209,8 @@ let assemble_args_splice call_loc ffi js_splice arg_types args : E.t list * E.t args, begin match eff with | [] -> None - | x::xs -> Some (List.fold_left (fun x y -> E.seq x y) x xs) + | x::xs -> + Some (fuse x xs) end @@ -182,7 +219,7 @@ let translate_ffi call_loc (ffi : Ast_ffi_types.ffi ) prim_name arg_types result_type (args : J.expression list) = match ffi with - | Obj_create labels -> assemble_args_obj labels args + | Js_call{ external_module_name = module_name; name = fn; splice = js_splice ; @@ -197,10 +234,10 @@ let translate_ffi call_loc (ffi : Ast_ffi_types.ffi ) prim_name add_eff eff (if result_type then - E.seq (E.call ~info:{arity=Full; call_info = Call_na} fn args) E.unit - else - E.call ~info:{arity=Full; call_info = Call_na} fn args) - + E.seq (E.call ~info:{arity=Full; call_info = Call_na} fn args) E.unit + else + E.call ~info:{arity=Full; call_info = Call_na} fn args) + | Js_module_as_var module_name -> let (id, name) = handle_external module_name in E.external_var_dot id ~external_name:name @@ -347,5 +384,6 @@ let translate loc cxt match Ast_ffi_types.from_string prim_native_name with | Ffi_normal -> Lam_dispatch_primitive.translate prim_name args + | Ffi_obj_create labels -> assemble_args_obj labels args | Ffi_bs (arg_types, result_type, ffi) -> translate_ffi loc ffi prim_name cxt arg_types result_type args diff --git a/jscomp/core/lam_compile_group.ml b/jscomp/core/lam_compile_group.ml index b9c3cb4c28..0827da959a 100644 --- a/jscomp/core/lam_compile_group.ml +++ b/jscomp/core/lam_compile_group.ml @@ -186,8 +186,10 @@ let compile ~filename output_prefix env _sigs let export_ident_sets = Ident_set.of_list export_idents in (* To make toplevel happy - reentrant for js-demo *) let () = +#if BS_DEBUG then export_idents |> List.iter (fun (id : Ident.t) -> Ext_log.dwarn __LOC__ "export: %s/%d" id.name id.stamp) ; +#end Lam_compile_env.reset () ; in let lam = Lam.convert export_ident_sets lam in @@ -367,7 +369,7 @@ let lambda_as_module begin Js_config.set_current_file filename ; #if BS_DEBUG then - Js_config.set_debug_file "gpr_1060_test.ml"; + Js_config.set_debug_file "gpr_1072.ml"; #end let lambda_output = compile ~filename output_prefix env sigs lam in let (//) = Filename.concat in diff --git a/jscomp/ounit_tests/ounit_cmd_tests.ml b/jscomp/ounit_tests/ounit_cmd_tests.ml index 650a488cbf..b15e3d1cb2 100644 --- a/jscomp/ounit_tests/ounit_cmd_tests.ml +++ b/jscomp/ounit_tests/ounit_cmd_tests.ml @@ -1,18 +1,6 @@ let (//) = Filename.concat -(** may nonterminate when [cwd] is '.' *) -let rec unsafe_root_dir_aux cwd = - if Sys.file_exists (cwd//Literals.bsconfig_json) then cwd - else unsafe_root_dir_aux (Filename.dirname cwd) -let project_root = unsafe_root_dir_aux (Sys.getcwd ()) -let jscomp = project_root // "jscomp" -let bsc_bin = jscomp // "bin" - -let bsc_exe = bsc_bin // "bsc.exe" -let runtime_dir = jscomp // "runtime" -let others_dir = jscomp // "others" -let stdlib_dir = jscomp // "stdlib" let ((>::), @@ -22,105 +10,13 @@ let (=~) = OUnit.assert_equal -let rec safe_dup fd = - let new_fd = Unix.dup fd in - if (Obj.magic new_fd : int) >= 3 then - new_fd (* [dup] can not be 0, 1, 2*) - else begin - let res = safe_dup fd in - Unix.close new_fd; - res - end - -let safe_close fd = - try Unix.close fd with Unix.Unix_error(_,_,_) -> () - - -type output = { - stderr : string ; - stdout : string ; - exit_code : int -} - -let perform command args = - let new_fd_in, new_fd_out = Unix.pipe () in - let err_fd_in, err_fd_out = Unix.pipe () in - match Unix.fork () with - | 0 -> - begin try - safe_close new_fd_in; - safe_close err_fd_in; - Unix.dup2 err_fd_out Unix.stderr ; - Unix.dup2 new_fd_out Unix.stdout; - Unix.execv command args - with _ -> - exit 127 - end - | pid -> - (* when all the descriptors on a pipe's input are closed and the pipe is - empty, a call to [read] on its output returns zero: end of file. - when all the descriptiors on a pipe's output are closed, a call to - [write] on its input kills the writing process (EPIPE). - *) - safe_close new_fd_out ; - safe_close err_fd_out ; - let in_chan = Unix.in_channel_of_descr new_fd_in in - let err_in_chan = Unix.in_channel_of_descr err_fd_in in - let buf = Buffer.create 1024 in - let err_buf = Buffer.create 1024 in - (try - while true do - Buffer.add_string buf (input_line in_chan ); - Buffer.add_char buf '\n' - done; - with - End_of_file -> ()) ; - (try - while true do - Buffer.add_string err_buf (input_line err_in_chan ); - Buffer.add_char err_buf '\n' - done; - with - End_of_file -> ()) ; - let exit_code = match snd @@ Unix.waitpid [] pid with - | Unix.WEXITED exit_code -> exit_code - | Unix.WSIGNALED _signal_number - | Unix.WSTOPPED _signal_number -> 127 in - { - stdout = Buffer.contents buf ; - stderr = Buffer.contents err_buf; - exit_code - } - - -let perform_bsc args = - perform bsc_exe - (Array.append - [|bsc_exe ; - "-bs-package-name" ; "bs-platform"; - "-bs-no-version-header"; - "-bs-cross-module-opt"; - "-w"; - "-40"; - "-I" ; - runtime_dir ; - "-I"; - others_dir ; - "-I" ; - stdlib_dir - |] args) - -let bsc_eval str = - perform_bsc [|"-bs-eval"; str|] + (* let output_of_exec_command command args = let readme, writeme = Unix.pipe () in let pid = Unix.create_process command args Unix.stdin writeme Unix.stderr in let in_chan = Unix.in_channel_of_descr readme *) -let debug_output o = - Printf.printf "\nexit_code:%d\nstdout:%s\nstderr:%s\n" - o.exit_code o.stdout o.stderr let react = {| type u @@ -147,6 +43,9 @@ let d = bar () |} +let perform_bsc = Ounit_cmd_util.perform_bsc +let bsc_eval = Ounit_cmd_util.bsc_eval + let suites = __FILE__ diff --git a/jscomp/ounit_tests/ounit_cmd_util.ml b/jscomp/ounit_tests/ounit_cmd_util.ml new file mode 100644 index 0000000000..47a1c977d7 --- /dev/null +++ b/jscomp/ounit_tests/ounit_cmd_util.ml @@ -0,0 +1,110 @@ +let (//) = Filename.concat + +(** may nonterminate when [cwd] is '.' *) +let rec unsafe_root_dir_aux cwd = + if Sys.file_exists (cwd//Literals.bsconfig_json) then cwd + else unsafe_root_dir_aux (Filename.dirname cwd) + +let project_root = unsafe_root_dir_aux (Sys.getcwd ()) +let jscomp = project_root // "jscomp" +let bsc_bin = jscomp // "bin" + +let bsc_exe = bsc_bin // "bsc.exe" +let runtime_dir = jscomp // "runtime" +let others_dir = jscomp // "others" +let stdlib_dir = jscomp // "stdlib" + +let rec safe_dup fd = + let new_fd = Unix.dup fd in + if (Obj.magic new_fd : int) >= 3 then + new_fd (* [dup] can not be 0, 1, 2*) + else begin + let res = safe_dup fd in + Unix.close new_fd; + res + end + +let safe_close fd = + try Unix.close fd with Unix.Unix_error(_,_,_) -> () + + +type output = { + stderr : string ; + stdout : string ; + exit_code : int +} + +let perform command args = + let new_fd_in, new_fd_out = Unix.pipe () in + let err_fd_in, err_fd_out = Unix.pipe () in + match Unix.fork () with + | 0 -> + begin try + safe_close new_fd_in; + safe_close err_fd_in; + Unix.dup2 err_fd_out Unix.stderr ; + Unix.dup2 new_fd_out Unix.stdout; + Unix.execv command args + with _ -> + exit 127 + end + | pid -> + (* when all the descriptors on a pipe's input are closed and the pipe is + empty, a call to [read] on its output returns zero: end of file. + when all the descriptiors on a pipe's output are closed, a call to + [write] on its input kills the writing process (EPIPE). + *) + safe_close new_fd_out ; + safe_close err_fd_out ; + let in_chan = Unix.in_channel_of_descr new_fd_in in + let err_in_chan = Unix.in_channel_of_descr err_fd_in in + let buf = Buffer.create 1024 in + let err_buf = Buffer.create 1024 in + (try + while true do + Buffer.add_string buf (input_line in_chan ); + Buffer.add_char buf '\n' + done; + with + End_of_file -> ()) ; + (try + while true do + Buffer.add_string err_buf (input_line err_in_chan ); + Buffer.add_char err_buf '\n' + done; + with + End_of_file -> ()) ; + let exit_code = match snd @@ Unix.waitpid [] pid with + | Unix.WEXITED exit_code -> exit_code + | Unix.WSIGNALED _signal_number + | Unix.WSTOPPED _signal_number -> 127 in + { + stdout = Buffer.contents buf ; + stderr = Buffer.contents err_buf; + exit_code + } + + +let perform_bsc args = + perform bsc_exe + (Array.append + [|bsc_exe ; + "-bs-package-name" ; "bs-platform"; + "-bs-no-version-header"; + "-bs-cross-module-opt"; + "-w"; + "-40"; + "-I" ; + runtime_dir ; + "-I"; + others_dir ; + "-I" ; + stdlib_dir + |] args) + +let bsc_eval str = + perform_bsc [|"-bs-eval"; str|] + + let debug_output o = + Printf.printf "\nexit_code:%d\nstdout:%s\nstderr:%s\n" + o.exit_code o.stdout o.stderr diff --git a/jscomp/ounit_tests/ounit_cmd_util.mli b/jscomp/ounit_tests/ounit_cmd_util.mli new file mode 100644 index 0000000000..502c278b69 --- /dev/null +++ b/jscomp/ounit_tests/ounit_cmd_util.mli @@ -0,0 +1,16 @@ +type output = { + stderr : string ; + stdout : string ; + exit_code : int +} + + +val perform : string -> string array -> output + + +val perform_bsc : string array -> output + + +val bsc_eval : string -> output + +val debug_output : output -> unit \ No newline at end of file diff --git a/jscomp/ounit_tests/ounit_ffi_error_debug_test.ml b/jscomp/ounit_tests/ounit_ffi_error_debug_test.ml new file mode 100644 index 0000000000..3c18ce4acc --- /dev/null +++ b/jscomp/ounit_tests/ounit_ffi_error_debug_test.ml @@ -0,0 +1,52 @@ +let (//) = Filename.concat + + + + +let ((>::), + (>:::)) = OUnit.((>::),(>:::)) + +let (=~) = OUnit.assert_equal + + + + +let bsc_eval = Ounit_cmd_util.bsc_eval + +let debug_output = Ounit_cmd_util.debug_output + + +let suites = + __FILE__ + >::: [ + __LOC__ >:: begin fun _ -> + let output = bsc_eval {| +external err : + hi_should_error:([`a of int | `b of string ] [@bs.string]) -> + unit -> _ = "" [@@bs.obj] + |} in + OUnit.assert_bool __LOC__ + (Ext_string.contain_substring output.stderr "hi_should_error") + end; + __LOC__ >:: begin fun _ -> +let output = bsc_eval {| + external err : + ?hi_should_error:([`a of int | `b of string ] [@bs.string]) -> + unit -> _ = "" [@@bs.obj] + |} in + OUnit.assert_bool __LOC__ + (Ext_string.contain_substring output.stderr "hi_should_error") + end; + __LOC__ >:: begin fun _ -> + let output = bsc_eval {| + external err : + ?hi_should_error:([`a of int | `b of string ] [@bs.string]) -> + unit -> unit = "" [@@bs.val] + |} in + OUnit.assert_bool __LOC__ + (Ext_string.contain_substring output.stderr "hi_should_error") + end + + + + ] \ No newline at end of file diff --git a/jscomp/ounit_tests/ounit_tests_main.ml b/jscomp/ounit_tests/ounit_tests_main.ml index d5b5786cfc..0da7d55824 100644 --- a/jscomp/ounit_tests/ounit_tests_main.ml +++ b/jscomp/ounit_tests/ounit_tests_main.ml @@ -35,7 +35,8 @@ let suites = Ounit_sexp_tests.suites; Ounit_int_vec_tests.suites; Ounit_ident_mask_tests.suites; - Ounit_cmd_tests.suites + Ounit_cmd_tests.suites; + Ounit_ffi_error_debug_test.suites; ] let _ = OUnit.run_test_tt_main suites diff --git a/jscomp/syntax/ast_core_type.ml b/jscomp/syntax/ast_core_type.ml index 7cb30809df..faf0b66268 100644 --- a/jscomp/syntax/ast_core_type.ml +++ b/jscomp/syntax/ast_core_type.ml @@ -29,11 +29,11 @@ type arg_label = | Empty (* it will be ignored , side effect will be recorded *) type arg_type = - | NullString of (int * string) list - | NonNullString of (int * string) list + | NullString of (int * string) list (* `a does not have any value*) + | NonNullString of (int * string) list (* `a of int *) | Int of (int * int ) list | Array - | Unit + | Extern_unit | Nothing | Ignore @@ -49,7 +49,23 @@ let extract_option_type_exn (ty : t) = | _ -> assert false end - +let predef_option : Longident.t = Longident.Ldot (Lident "*predef*", "option") +let predef_int : Longident.t = Ldot (Lident "*predef*", "int") + + +let lift_option_type (ty:t) : t = + {ptyp_desc = + Ptyp_constr( + {txt = predef_option; + loc = ty.ptyp_loc} + , [ty]); + ptyp_loc = ty.ptyp_loc; + ptyp_attributes = [] + } + +let is_any (ty : t) = + match ty with {ptyp_desc = Ptyp_any} -> true | _ -> false + open Ast_helper let replace_result ty result = @@ -73,12 +89,12 @@ let is_array (ty : t) = | Ptyp_constr({txt =Lident "array"}, [_]) -> true | _ -> false -let is_optional l = +let is_optional_label l = String.length l > 0 && l.[0] = '?' let label_name l : arg_label = if l = "" then Empty else - if is_optional l + if is_optional_label l then Optional (String.sub l 1 (String.length l - 1)) else Label l diff --git a/jscomp/syntax/ast_core_type.mli b/jscomp/syntax/ast_core_type.mli index 0f3bda25ea..2b2bc6cfd5 100644 --- a/jscomp/syntax/ast_core_type.mli +++ b/jscomp/syntax/ast_core_type.mli @@ -26,6 +26,8 @@ type t = Parsetree.core_type val extract_option_type_exn : t -> t +val lift_option_type : t -> t +val is_any : t -> bool val replace_result : t -> t -> t val is_unit : t -> bool @@ -39,7 +41,7 @@ type arg_type = | NonNullString of (int * string) list | Int of (int * int ) list | Array - | Unit + | Extern_unit | Nothing | Ignore @@ -65,3 +67,5 @@ val make_obj : loc:Location.t -> (string * Parsetree.attributes * t) list -> t + +val is_optional_label : string -> bool \ No newline at end of file diff --git a/jscomp/syntax/ast_external_attributes.ml b/jscomp/syntax/ast_external_attributes.ml index 4abd034510..13769b810e 100644 --- a/jscomp/syntax/ast_external_attributes.ml +++ b/jscomp/syntax/ast_external_attributes.ml @@ -37,10 +37,11 @@ ]} The result type would be [ hi:string ] *) -let get_arg_type - ({ptyp_desc; ptyp_attributes; ptyp_loc = loc} as ptyp : Ast_core_type.t) : +let get_arg_type ~nolabel optional + (ptyp : Ast_core_type.t) : Ast_core_type.arg_type * Ast_core_type.t = - match Ast_attributes.process_bs_string_int ptyp_attributes, ptyp_desc with + let ptyp = if optional then Ast_core_type.extract_option_type_exn ptyp else ptyp in + match Ast_attributes.process_bs_string_int ptyp.ptyp_attributes, ptyp.ptyp_desc with | (`String, ptyp_attributes), Ptyp_variant ( row_fields, Closed, None) -> let case, result, row_fields = @@ -68,16 +69,16 @@ let get_arg_type `NonNull, ((Ext_pervasives.hash_variant label, label) :: acc), (tag :: row_fields) end - | _ -> Location.raise_errorf ~loc "Not a valid string type" + | _ -> Location.raise_errorf ~loc:ptyp.ptyp_loc "Not a valid string type" ) row_fields (`Nothing, [], [])) in (match case with - | `Nothing -> Location.raise_errorf ~loc "Not a valid string type" + | `Nothing -> Location.raise_errorf ~loc:ptyp.ptyp_loc "Not a valid string type" | `Null -> NullString result | `NonNull -> NonNullString result) , {ptyp with ptyp_desc = Ptyp_variant(row_fields, Closed, None); ptyp_attributes ; } - | (`String, _), _ -> Location.raise_errorf ~loc "Not a valid string type" + | (`String, _), _ -> Location.raise_errorf ~loc:ptyp.ptyp_loc "Not a valid string type" | (`Ignore, ptyp_attributes), _ -> (Ignore, {ptyp with ptyp_attributes}) @@ -96,7 +97,7 @@ let get_arg_type i + 1 , ((Ext_pervasives.hash_variant label , i):: acc ), rtag::row_fields end - | _ -> Location.raise_errorf ~loc "Not a valid string type" + | _ -> Location.raise_errorf ~loc:ptyp.ptyp_loc "Not a valid string type" ) (0, [],[]) row_fields) in Int (List.rev acc), {ptyp with @@ -104,19 +105,19 @@ let get_arg_type ptyp_attributes } - | (`Int, _), _ -> Location.raise_errorf ~loc "Not a valid string type" + | (`Int, _), _ -> Location.raise_errorf ~loc:ptyp.ptyp_loc "Not a valid string type" | (`Nothing, ptyp_attributes), ptyp_desc -> begin match ptyp_desc with | Ptyp_constr ({txt = Lident "bool"}, []) -> - Bs_warnings.prerr_warning loc Unsafe_ffi_bool_type; + Bs_warnings.prerr_warning ptyp.ptyp_loc Unsafe_ffi_bool_type; Nothing | Ptyp_constr ({txt = Lident "unit"}, []) - -> Unit + -> if nolabel then Extern_unit else Nothing | Ptyp_constr ({txt = Lident "array"}, [_]) -> Array | Ptyp_variant _ -> - Bs_warnings.prerr_warning loc Unsafe_poly_variant_type; + Bs_warnings.prerr_warning ptyp.ptyp_loc Unsafe_poly_variant_type; Nothing | _ -> Nothing @@ -252,7 +253,7 @@ let process_external_attributes (init_st, []) prim_attributes -let list_of_arrow_clean_option_label (ty : Parsetree.core_type) = +let list_of_arrow (ty : Parsetree.core_type) = let rec aux (ty : Parsetree.core_type) acc = match ty.ptyp_desc with | Ptyp_arrow(label,t1,t2) -> @@ -262,6 +263,7 @@ let list_of_arrow_clean_option_label (ty : Parsetree.core_type) = | return_type -> ty, List.rev acc in aux ty [] + (** Note that the passed [type_annotation] is already processed by visitor pattern before *) let handle_attributes @@ -275,43 +277,18 @@ let handle_attributes else `Nm_external prim_name (* need check name *) in let result_type, arg_types_ty = - list_of_arrow_clean_option_label type_annotation in + list_of_arrow type_annotation in let result_type_spec, new_result_type = - get_arg_type result_type in + get_arg_type ~nolabel:true false result_type in (* result type can not be labeled *) let (st, left_attrs) = process_external_attributes (arg_types_ty = []) prim_name_or_pval_prim pval_prim prim_attributes in - let splice = st.splice in - let arg_type_specs, new_arg_types_ty, arg_type_specs_length = - List.fold_right - (fun (label,ty,attr,loc) (arg_type_specs, arg_types, i) -> - let arg_type, new_ty = get_arg_type ty in - (if i = 0 && splice then - match arg_type with - | Array -> () - | _ -> Location.raise_errorf ~loc "[@@bs.splice] expect last type to array"); - ({ Ast_ffi_types.arg_label = Ast_core_type.label_name label ; - arg_type - } :: arg_type_specs, - (label, new_ty,attr,loc) :: arg_types, - i + 1) - ) arg_types_ty - (match st with - | {val_send_pipe = Some obj} -> - let arg_type, new_ty = get_arg_type obj in - [{ arg_label = Empty ; - arg_type - }], - ["", new_ty, [], obj.ptyp_loc] - ,0 - | {val_send_pipe = None } -> [],[], 0) in - - - let ffi = - match st with - | { mk_obj = true; + + if st.mk_obj then + begin match st with + | { val_name = `Nm_na; external_module_name = None ; module_as_val = None; @@ -323,314 +300,385 @@ let handle_attributes set_name = `Nm_na ; get_name = `Nm_na ; get_index = false ; - } -> - if String.length prim_name <> 0 then - Location.raise_errorf ~loc "[@@bs.obj] expect external names to be empty string"; - Ast_ffi_types.Obj_create (List.map (function - | {Ast_ffi_types.arg_label = (Empty as l) ; arg_type = Unit } - -> l - | {arg_label = Empty ; arg_type = _ } - -> Location.raise_errorf ~loc "expect label, optional, or unit here" - | {arg_label = (Label _) ; arg_type = (Ignore | Unit) ; } - -> Empty - | {arg_label = Label name ; arg_type = (Nothing | Array)} -> - Label (Lam_methname.translate ~loc name) - | {arg_label = Label l ; arg_type = (NullString _ | NonNullString _ | Int _ ) } - -> Location.raise_errorf ~loc - "bs.obj label %s does not support such arg type" l - | {arg_label = Optional name ; arg_type = (Nothing | Array | Unit | Ignore)} - -> Optional (Lam_methname.translate ~loc name) - | {arg_label = Optional l ; arg_type = (NullString _ | NonNullString _ | Int _)} - -> Location.raise_errorf ~loc - "bs.obj optional %s does not support such arg type" l ) - arg_type_specs)(* Need fetch label here, for better error message *) - | {mk_obj = true; _} - -> - Location.raise_errorf ~loc "conflict attributes found" - | {set_index = true; - - val_name = `Nm_na; - external_module_name = None ; - module_as_val = None; - val_send = `Nm_na; - val_send_pipe = None; - splice = false; - get_index = false; - new_name = `Nm_na; - call_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - mk_obj = false ; - - } - -> - if String.length prim_name <> 0 then - Location.raise_errorf ~loc "[@@bs.set_index] expect external names to be empty string"; - if arg_type_specs_length = 3 then - Js_set_index - else - Location.raise_errorf ~loc "Ill defined attribute [@@bs.set_index](arity of 3)" - - | {set_index = true; _} - -> - Location.raise_errorf ~loc "conflict attributes found" - - | {get_index = true; - - val_name = `Nm_na; - external_module_name = None ; - module_as_val = None; - val_send = `Nm_na; - val_send_pipe = None; - - splice = false; - new_name = `Nm_na; - call_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - mk_obj = false ; - } -> - if String.length prim_name <> 0 then - Location.raise_errorf ~loc "[@@bs.get_index] expect external names to be empty string"; - if arg_type_specs_length = 2 then - Js_get_index - else Location.raise_errorf ~loc "Ill defined attribute [@@bs.get_index] (arity of 2)" - - | {get_index = true; _} - -> Location.raise_errorf ~loc "conflict attributes found" - - - (*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] ]} - *) - | {module_as_val = Some external_module_name ; - - get_index = false; - val_name ; - new_name ; - - external_module_name = None ; - val_send = `Nm_na; - val_send_pipe = None; - splice ; - call_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - mk_obj = false ;} -> - begin match arg_types_ty, new_name, val_name with - | [], `Nm_na, _ -> Js_module_as_var external_module_name - | _, `Nm_na, _ -> Js_module_as_fn {splice; external_module_name } - | _, #bundle_source, #bundle_source -> - Location.raise_errorf ~loc "conflict attributes found" - | _, (`Nm_val _ | `Nm_external _) , `Nm_na - -> Js_module_as_class external_module_name - | _, `Nm_payload _ , `Nm_na - -> - Location.raise_errorf ~loc - "conflict attributes found: (bs.new should not carry payload here)" - - end - | {module_as_val = Some _} - -> Location.raise_errorf ~loc "conflict attributes found" - | {call_name = (`Nm_val name | `Nm_external name | `Nm_payload name) ; - splice; - external_module_name; - - val_name = `Nm_na ; - module_as_val = None; - val_send = `Nm_na ; - val_send_pipe = None; - - set_index = false; - get_index = false; - new_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na } -> - Js_call {splice; name; external_module_name} - | {call_name = #bundle_source } - -> Location.raise_errorf ~loc "conflict attributes found" - - | {val_name = (`Nm_val name | `Nm_external name | `Nm_payload name); - external_module_name; - - call_name = `Nm_na ; - module_as_val = None; - val_send = `Nm_na ; - val_send_pipe = None; - set_index = false; - get_index = false; - new_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na - - } - -> - Js_global { name; external_module_name} - | {val_name = #bundle_source } - -> Location.raise_errorf ~loc "conflict attributes found" - | {splice ; - external_module_name = (Some _ as external_module_name); - - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - val_send = `Nm_na ; - val_send_pipe = None; - set_index = false; - get_index = false; - new_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - - } - -> - let name = string_of_bundle_source prim_name_or_pval_prim in - if arg_type_specs_length = 0 then + if String.length prim_name <> 0 then + Location.raise_errorf ~loc "[@@bs.obj] expect external names to be empty string"; + let arg_kinds, new_arg_types_ty, result_types = + List.fold_right + (fun (label,ty,attr,loc) ( arg_labels, arg_types, result_types) -> + let arg_label = Ast_core_type.label_name label in + let new_arg_label, new_ty, output_tys = + match arg_label with + | Empty -> + let arg_type, new_ty = get_arg_type ~nolabel:true false ty in + begin match arg_type with + | Extern_unit -> { Ast_ffi_types. arg_label; arg_type }, new_ty, result_types + | _ -> + Location.raise_errorf ~loc "expect label, optional, or unit here" + end + | Label name -> + let arg_type, new_ty = get_arg_type ~nolabel:false false ty in + begin match arg_type with + | Ignore -> { arg_label = Empty ; arg_type }, new_ty, result_types + + | Nothing | Array -> + let s = (Lam_methname.translate ~loc name) in + {arg_label = Label s ; arg_type }, new_ty, + ((name , [], new_ty) :: result_types) + | Int _ -> + let s = Lam_methname.translate ~loc name in + {arg_label = Label s; arg_type}, new_ty, ((name, [], Ast_literal.type_int ~loc ()) :: result_types) + | NullString _ -> + let s = Lam_methname.translate ~loc name in + {arg_label = Label s; arg_type}, new_ty, + ((name, [], Ast_literal.type_string ~loc ()) :: result_types) + | Extern_unit -> assert false + | NonNullString _ + -> + Location.raise_errorf ~loc + "bs.obj label %s does not support such arg type" name + end + | Optional name -> + let arg_type, new_ty_extract = get_arg_type ~nolabel:false true ty in + let new_ty = Ast_core_type.lift_option_type new_ty_extract in + begin match arg_type with + | Ignore -> + {arg_label = Empty ; arg_type}, new_ty, result_types + + | Nothing | Array -> + let s = (Lam_methname.translate ~loc name) in + {arg_label = Optional s; arg_type}, new_ty, + ( (name, [], Ast_comb.to_undefined_type loc new_ty_extract) :: result_types) + | Int _ -> + let s = Lam_methname.translate ~loc name in + {arg_label = Optional s ; arg_type }, new_ty, + ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_int ~loc ()) :: result_types) + | NullString _ -> + let s = Lam_methname.translate ~loc name in + {arg_label = Optional s ; arg_type }, new_ty, + ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_string ~loc ()) :: result_types) + | Extern_unit -> assert false + | NonNullString _ + -> + Location.raise_errorf ~loc + "bs.obj label %s does not support such arg type" name + end + in + ( + new_arg_label::arg_labels, + (label, new_ty,attr,loc) :: arg_types, + output_tys)) arg_types_ty + ( [], [], []) in + let result = + if Ast_core_type.is_any new_result_type then + Ast_core_type.make_obj ~loc result_types + else new_result_type + in + begin + ( + List.fold_right (fun (label,ty,attrs,loc) acc -> + Ast_helper.Typ.arrow ~loc ~attrs label ty acc + ) new_arg_types_ty result + ) , + prim_name, + Ffi_obj_create arg_kinds, + left_attrs + end + + | _ -> Location.raise_errorf ~loc "conflict attributes found [@@bs.obj]" + + end + + else + let splice = st.splice in + let arg_type_specs, new_arg_types_ty, arg_type_specs_length = + List.fold_right + (fun (label,ty,attr,loc) (arg_type_specs, arg_types, i) -> + let arg_label = Ast_core_type.label_name label in + let arg_type, new_ty = + match arg_label with + | Optional _ -> + + let arg_type , new_ty = get_arg_type ~nolabel:false true ty in + begin match arg_type with + | NonNullString _ -> + (* ?x:([`x of int ] [@bs.string]) does not make sense *) + Location.raise_errorf + ~loc + "[@@bs.string] does not work with optional when it has arities in label %s" label + | _ -> + arg_type, Ast_core_type.lift_option_type new_ty end + | Label _ | Empty -> + get_arg_type ~nolabel:(arg_label = Empty) false ty in + (if i = 0 && splice then + match arg_type with + | Array -> () + | _ -> Location.raise_errorf ~loc "[@@bs.splice] expect last type to array"); + ({ Ast_ffi_types.arg_label ; + arg_type + } :: arg_type_specs, + (label, new_ty,attr,loc) :: arg_types, + i + 1) + ) arg_types_ty + (match st with + | {val_send_pipe = Some obj} -> + let arg_type, new_ty = get_arg_type ~nolabel:true false obj in + [{ arg_label = Empty ; + arg_type + }], + ["", new_ty, [], obj.ptyp_loc] + ,0 + | {val_send_pipe = None } -> [],[], 0) in + + let ffi : Ast_ffi_types.ffi = match st with + | {set_index = true; + + val_name = `Nm_na; + external_module_name = None ; + module_as_val = None; + val_send = `Nm_na; + val_send_pipe = None; + splice = false; + get_index = false; + new_name = `Nm_na; + call_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + } + -> + if String.length prim_name <> 0 then + Location.raise_errorf ~loc "[@@bs.set_index] expect external names to be empty string"; + if arg_type_specs_length = 3 then + Js_set_index + else + Location.raise_errorf ~loc "Ill defined attribute [@@bs.set_index](arity of 3)" + + | {set_index = true; _} + -> + Location.raise_errorf ~loc "conflict attributes found" + + | {get_index = true; + + val_name = `Nm_na; + external_module_name = None ; + module_as_val = None; + val_send = `Nm_na; + val_send_pipe = None; + + splice = false; + new_name = `Nm_na; + call_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + } -> + if String.length prim_name <> 0 then + Location.raise_errorf ~loc "[@@bs.get_index] expect external names to be empty string"; + if arg_type_specs_length = 2 then + Js_get_index + else Location.raise_errorf ~loc "Ill defined attribute [@@bs.get_index] (arity of 2)" + + | {get_index = true; _} + -> Location.raise_errorf ~loc "conflict attributes found" + + + + | {module_as_val = Some external_module_name ; + + get_index = false; + val_name ; + new_name ; + + external_module_name = None ; + val_send = `Nm_na; + val_send_pipe = None; + splice ; + call_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + mk_obj = false ;} -> + begin match arg_types_ty, new_name, val_name with + | [], `Nm_na, _ -> Js_module_as_var external_module_name + | _, `Nm_na, _ -> Js_module_as_fn {splice; external_module_name } + | _, #bundle_source, #bundle_source -> + Location.raise_errorf ~loc "conflict attributes found" + | _, (`Nm_val _ | `Nm_external _) , `Nm_na + -> Js_module_as_class external_module_name + | _, `Nm_payload _ , `Nm_na + -> + Location.raise_errorf ~loc + "conflict attributes found: (bs.new should not carry payload here)" + + end + | {module_as_val = Some _} + -> Location.raise_errorf ~loc "conflict attributes found" + | {call_name = (`Nm_val name | `Nm_external name | `Nm_payload name) ; + splice; + external_module_name; + + val_name = `Nm_na ; + module_as_val = None; + val_send = `Nm_na ; + val_send_pipe = None; + + set_index = false; + get_index = false; + new_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na + } -> + Js_call {splice; name; external_module_name} + | {call_name = #bundle_source } + -> Location.raise_errorf ~loc "conflict attributes found" + + | {val_name = (`Nm_val name | `Nm_external name | `Nm_payload name); + external_module_name; + + call_name = `Nm_na ; + module_as_val = None; + val_send = `Nm_na ; + val_send_pipe = None; + set_index = false; + get_index = false; + new_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na + + } + -> Js_global { name; external_module_name} - else Js_call {splice; name; external_module_name} - | {val_send = (`Nm_val name | `Nm_external name | `Nm_payload name); - splice; - val_send_pipe = None; - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - set_index = false; - get_index = false; - new_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - external_module_name = None ; - } -> - if arg_type_specs_length > 0 then - Js_send {splice ; name; pipe = false} - else - Location.raise_errorf ~loc "Ill defined attribute [@@bs.send] (at least one argument)" - | {val_send = #bundle_source} - -> Location.raise_errorf ~loc "conflict attributes found" - - | {val_send_pipe = Some typ; - (* splice = (false as splice); *) - val_send = `Nm_na; - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - set_index = false; - get_index = false; - new_name = `Nm_na; - set_name = `Nm_na ; - get_name = `Nm_na ; - external_module_name = None ; - } -> - (** can be one argument *) - Js_send {splice ; - name = string_of_bundle_source prim_name_or_pval_prim; - pipe = true} - - | {val_send_pipe = Some _ } - -> Location.raise_errorf ~loc "conflict attributes found" - - | {new_name = (`Nm_val name | `Nm_external name | `Nm_payload name); - external_module_name; - - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - set_index = false; - get_index = false; - val_send = `Nm_na ; - val_send_pipe = None; - set_name = `Nm_na ; - get_name = `Nm_na ; - splice - } - -> Js_new {name; external_module_name; splice} - | {new_name = #bundle_source } - -> Location.raise_errorf ~loc "conflict attributes found" - - | {set_name = (`Nm_val name | `Nm_external name | `Nm_payload name); - - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - set_index = false; - get_index = false; - val_send = `Nm_na ; - val_send_pipe = None; - new_name = `Nm_na ; - get_name = `Nm_na ; - external_module_name = None - } - -> - if arg_type_specs_length = 2 then - Js_set name - else Location.raise_errorf ~loc "Ill defined attribute [@@bs.set] (two args required)" - - | {set_name = #bundle_source} - -> Location.raise_errorf ~loc "conflict attributes found" - - | {get_name = (`Nm_val name | `Nm_external name | `Nm_payload name); - - val_name = `Nm_na ; - call_name = `Nm_na ; - module_as_val = None; - set_index = false; - get_index = false; - val_send = `Nm_na ; - val_send_pipe = None; - new_name = `Nm_na ; - set_name = `Nm_na ; - external_module_name = None - } - -> - if arg_type_specs_length = 1 then - Js_get name - else - Location.raise_errorf ~loc "Ill defined attribute [@@bs.get] (only one argument)" - | {get_name = #bundle_source} - -> Location.raise_errorf ~loc "conflict attributes found" - | _ -> Location.raise_errorf ~loc "Illegal attribute found" in - begin - Ast_ffi_types.check_ffi ~loc ffi; - (match ffi, new_result_type with - | Obj_create arg_labels , {ptyp_desc = Ptyp_any; _} - -> - (* special case: - {[ external f : int -> string -> _ = "" ]} - *) - let result = - Ast_core_type.make_obj ~loc ( - List.fold_right2 - (fun arg (label : Ast_core_type.arg_label) acc -> - match arg, label with - | (_, ty, _,_), Label s - -> (s , [], ty) :: acc - | (_, ty, _,_), Optional s - -> - (s, [], - Ast_comb.to_undefined_type loc @@ - Ast_core_type.extract_option_type_exn ty - ) :: acc - | (_, _, _,_), Empty -> acc - ) arg_types_ty arg_labels []) in - - List.fold_right (fun (label,ty,attrs,loc) acc -> - Ast_helper.Typ.arrow ~loc ~attrs label ty acc - ) new_arg_types_ty result - - (* Ast_core_type.replace_result type_annotation result *) - | _ -> - List.fold_right (fun (label,ty,attrs,loc) acc -> - Ast_helper.Typ.arrow ~loc ~attrs label ty acc - ) new_arg_types_ty new_result_type - ) , - prim_name, - (Ffi_bs (arg_type_specs, result_type_spec = Unit , ffi)), left_attrs - end + | {val_name = #bundle_source } + -> Location.raise_errorf ~loc "conflict attributes found" + | {splice ; + external_module_name = (Some _ as external_module_name); + + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + val_send = `Nm_na ; + val_send_pipe = None; + set_index = false; + get_index = false; + new_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + + } + -> + let name = string_of_bundle_source prim_name_or_pval_prim in + if arg_type_specs_length = 0 then + Js_global { name; external_module_name} + else Js_call {splice; name; external_module_name} + | {val_send = (`Nm_val name | `Nm_external name | `Nm_payload name); + splice; + val_send_pipe = None; + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + set_index = false; + get_index = false; + new_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + external_module_name = None ; + } -> + if arg_type_specs_length > 0 then + Js_send {splice ; name; pipe = false} + else + Location.raise_errorf ~loc "Ill defined attribute [@@bs.send] (at least one argument)" + | {val_send = #bundle_source} + -> Location.raise_errorf ~loc "conflict attributes found" + + | {val_send_pipe = Some typ; + (* splice = (false as splice); *) + val_send = `Nm_na; + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + set_index = false; + get_index = false; + new_name = `Nm_na; + set_name = `Nm_na ; + get_name = `Nm_na ; + external_module_name = None ; + } -> + (** can be one argument *) + Js_send {splice ; + name = string_of_bundle_source prim_name_or_pval_prim; + pipe = true} + + | {val_send_pipe = Some _ } + -> Location.raise_errorf ~loc "conflict attributes found" + + | {new_name = (`Nm_val name | `Nm_external name | `Nm_payload name); + external_module_name; + + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + set_index = false; + get_index = false; + val_send = `Nm_na ; + val_send_pipe = None; + set_name = `Nm_na ; + get_name = `Nm_na ; + splice + } + -> Js_new {name; external_module_name; splice} + | {new_name = #bundle_source } + -> Location.raise_errorf ~loc "conflict attributes found" + + | {set_name = (`Nm_val name | `Nm_external name | `Nm_payload name); + + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + set_index = false; + get_index = false; + val_send = `Nm_na ; + val_send_pipe = None; + new_name = `Nm_na ; + get_name = `Nm_na ; + external_module_name = None + } + -> + if arg_type_specs_length = 2 then + Js_set name + else Location.raise_errorf ~loc "Ill defined attribute [@@bs.set] (two args required)" + + | {set_name = #bundle_source} + -> Location.raise_errorf ~loc "conflict attributes found" + + | {get_name = (`Nm_val name | `Nm_external name | `Nm_payload name); + + val_name = `Nm_na ; + call_name = `Nm_na ; + module_as_val = None; + set_index = false; + get_index = false; + val_send = `Nm_na ; + val_send_pipe = None; + new_name = `Nm_na ; + set_name = `Nm_na ; + external_module_name = None + } + -> + if arg_type_specs_length = 1 then + Js_get name + else + Location.raise_errorf ~loc "Ill defined attribute [@@bs.get] (only one argument)" + | {get_name = #bundle_source} + -> Location.raise_errorf ~loc "conflict attributes found" + | _ -> Location.raise_errorf ~loc "Illegal attribute found" in + begin + Ast_ffi_types.check_ffi ~loc ffi; + ( + List.fold_right (fun (label,ty,attrs,loc) acc -> + Ast_helper.Typ.arrow ~loc ~attrs label ty acc + ) new_arg_types_ty new_result_type + ) , + prim_name, + (Ffi_bs (arg_type_specs, result_type_spec = Extern_unit , ffi)), left_attrs + end let handle_attributes_as_string pval_loc @@ -642,16 +690,16 @@ let handle_attributes_as_string let pval_prim_of_labels labels = let encoding = - let (arg_kinds, vs) = + let arg_kinds = List.fold_right - (fun {Asttypes.loc ; txt } (arg_kinds,v) + (fun {Asttypes.loc ; txt } arg_kinds -> let arg_label = Ast_core_type.Label (Lam_methname.translate ~loc txt) in {Ast_ffi_types.arg_type = Nothing ; - arg_label } :: arg_kinds, arg_label :: v + arg_label } :: arg_kinds ) - labels ([],[]) in - Ast_ffi_types.to_string @@ - Ffi_bs (arg_kinds , false, Obj_create vs) in + labels [] in + Ast_ffi_types.to_string + (Ffi_obj_create arg_kinds) in [""; encoding] diff --git a/jscomp/syntax/ast_ffi_types.ml b/jscomp/syntax/ast_ffi_types.ml index 1006145deb..3cb4cffac1 100644 --- a/jscomp/syntax/ast_ffi_types.ml +++ b/jscomp/syntax/ast_ffi_types.ml @@ -65,10 +65,10 @@ type arg_kind = arg_type : arg_type; arg_label : arg_label } - +type obj_create = arg_kind list type ffi = - | Obj_create of arg_label list + (* | Obj_create of obj_create *) | Js_global of js_global_val | Js_module_as_var of external_module_name | Js_module_as_fn of js_module_as_fn @@ -99,14 +99,15 @@ let name_of_ffi ffi = | Js_global v -> Printf.sprintf "[@@bs.val] %S " v.name - | Obj_create _ -> - Printf.sprintf "[@@bs.obj]" + (* | Obj_create _ -> + Printf.sprintf "[@@bs.obj]" *) type t = | Ffi_bs of arg_kind list * bool * ffi (** [Ffi_bs(args,return,ffi) ] [return] means return value is unit or not, [true] means is [unit] *) + | Ffi_obj_create of obj_create | Ffi_normal (* When it's normal, it is handled as normal c functional ffi call *) @@ -172,7 +173,7 @@ let check_ffi ?loc ffi = | Js_set name | Js_get name -> valid_method_name ?loc name - | Obj_create _ -> () + (* | Obj_create _ -> () *) | Js_get_index | Js_set_index -> () diff --git a/jscomp/syntax/ast_ffi_types.mli b/jscomp/syntax/ast_ffi_types.mli index 95f4e4f647..bd1a684478 100644 --- a/jscomp/syntax/ast_ffi_types.mli +++ b/jscomp/syntax/ast_ffi_types.mli @@ -66,9 +66,10 @@ type arg_kind = arg_label : arg_label } +type obj_create = arg_kind list type ffi = - | Obj_create of arg_label list + (* | Obj_create of obj_create*) | Js_global of js_global_val | Js_module_as_var of external_module_name | Js_module_as_fn of js_module_as_fn @@ -83,6 +84,7 @@ type ffi = type t = | Ffi_bs of arg_kind list * bool * ffi + | Ffi_obj_create of obj_create | Ffi_normal (* When it's normal, it is handled as normal c functional ffi call *) diff --git a/jscomp/syntax/ast_literal.ml b/jscomp/syntax/ast_literal.ml index c133ecc86f..31ff912aae 100644 --- a/jscomp/syntax/ast_literal.ml +++ b/jscomp/syntax/ast_literal.ml @@ -30,6 +30,7 @@ module Lid = struct let val_unit : t = Lident "()" let type_unit : t = Lident "unit" let type_string : t = Lident "string" + let type_int : t = Lident "int" (* use *predef* *) (* TODO should be renamed in to {!Js.fn} *) (* TODO should be moved into {!Js.t} Later *) let js_fn = Longident.Ldot (Lident "Js", "fn") @@ -50,7 +51,8 @@ module No_loc = struct Ast_helper.Exp.construct {txt = Lid.val_unit; loc } None let type_unit = Ast_helper.Typ.mk (Ptyp_constr ({ txt = Lid.type_unit; loc}, [])) - + let type_int = + Ast_helper.Typ.mk (Ptyp_constr ({txt = Lid.type_int; loc}, [])) let type_string = Ast_helper.Typ.mk (Ptyp_constr ({ txt = Lid.type_string; loc}, [])) @@ -83,6 +85,12 @@ let type_string ?loc () = | Some loc -> Ast_helper.Typ.mk ~loc (Ptyp_constr ({ txt = Lid.type_string; loc}, [])) +let type_int ?loc () = + match loc with + | None -> No_loc.type_int + | Some loc -> + Ast_helper.Typ.mk ~loc (Ptyp_constr ({ txt = Lid.type_int; loc}, [])) + let type_any ?loc () = match loc with | None -> No_loc.type_any diff --git a/jscomp/syntax/ast_literal.mli b/jscomp/syntax/ast_literal.mli index faa48273f2..fb88610466 100644 --- a/jscomp/syntax/ast_literal.mli +++ b/jscomp/syntax/ast_literal.mli @@ -28,6 +28,7 @@ module Lid : sig type t = Longident.t val val_unit : t val type_unit : t + val type_int : t val js_fn : t val js_meth : t val js_meth_callback : t @@ -50,7 +51,7 @@ val val_unit : expression_lit val type_unit : core_type_lit val type_string : core_type_lit - +val type_int : core_type_lit val type_any : core_type_lit val pat_unit : pattern_lit diff --git a/jscomp/test/.depend b/jscomp/test/.depend index bc405108c3..2a6301ad18 100644 --- a/jscomp/test/.depend +++ b/jscomp/test/.depend @@ -179,7 +179,7 @@ global_module_alias_test.cmj : mt.cmj ../stdlib/list.cmj google_closure_test.cmj : test_google_closure.cmj mt.cmj gpr496_test.cmj : ../stdlib/pervasives.cmj mt.cmj ../runtime/js.cmj gpr_1063_test.cmj : -gpr_1072_test.cmj : ../runtime/js.cmj +gpr_1072.cmj : ../runtime/js.cmj gpr_405_test.cmj : ../stdlib/hashtbl.cmj gpr_405_test.cmi gpr_441.cmj : gpr_459_test.cmj : mt.cmj diff --git a/jscomp/test/Makefile b/jscomp/test/Makefile index 1e529cfca2..e460b6c24b 100644 --- a/jscomp/test/Makefile +++ b/jscomp/test/Makefile @@ -79,7 +79,7 @@ OTHERS := literals a test_ari test_export2 test_internalOO test_obj_simple_ffi t minimal_test\ gpr_1063_test\ gpr_977_test\ - gpr_1072_test + gpr_1072 diff --git a/jscomp/test/gpr_1072.js b/jscomp/test/gpr_1072.js new file mode 100644 index 0000000000..b0b19138be --- /dev/null +++ b/jscomp/test/gpr_1072.js @@ -0,0 +1,185 @@ +'use strict'; + + +var u = { + y: 3 +}; + +var v_ice_cream3_000 = { + flavor: "vanilla", + num: 3 +}; + +var v_ice_cream3_001 = /* :: */[ + { + flavor: "x", + num: 3 + }, + /* :: */[ + { + flavor: "vanilla", + num: 3 + }, + /* [] */0 + ] +]; + +var v_ice_cream3 = /* :: */[ + v_ice_cream3_000, + v_ice_cream3_001 +]; + +var v_ice_cream4_000 = { + flavor: "vanilla", + num: 3 +}; + +var v_ice_cream4_001 = /* :: */[ + { + flavor: "x", + num: 3 + }, + /* [] */0 +]; + +var v_ice_cream4 = /* :: */[ + v_ice_cream4_000, + v_ice_cream4_001 +]; + +var vv = { + x: 3 +}; + +var int_expect = { + x: 0 +}; + +var int_expect2 = { + x: 0 +}; + +var int_expects_000 = { }; + +var int_expects_001 = /* :: */[ + { + x: 2 + }, + /* :: */[ + { + x: 3 + }, + /* [] */0 + ] +]; + +var int_expects = /* :: */[ + int_expects_000, + int_expects_001 +]; + +var mk_ice = { + flavour: "vanilla", + num: 3 +}; + +var my_ice2 = { + flavour: "vanilla", + num: 1 +}; + +var my_ice3 = { + num: 2 +}; + +var v_mk4 = { + y: 3 +}; + +var v_mk5 = { + x: /* () */0, + y: 3 +}; + +var v_mk6 = { + y: 3 +}; + +var v_mk6_1 = { + x: /* () */0, + y: 3 +}; + +var mk_u = mk(0); + +var v_mk7_000 = { + y: 3 +}; + +var v_mk7_001 = /* :: */[ + { + y: 2 + }, + /* :: */[ + { + y: 2 + }, + /* [] */0 + ] +]; + +var v_mk7 = /* :: */[ + v_mk7_000, + v_mk7_001 +]; + +again("a", 3); + +again(undefined, 3); + +again(undefined, 3); + +again(undefined, 3); + +again2("a", 3); + +again3(3); + +again3(2); + +var side_effect = [0]; + +again4(undefined, /* () */0, 166); + +again4(undefined, /* () */0, 167); + +again4(/* () */0, /* () */0, 168); + +again4(/* () */0, /* () */0, 169); + +again4(undefined, /* () */0, 170); + +again4((side_effect[0] = side_effect[0] + 1 | 0, /* () */0), /* () */0, 171); + +again4((side_effect[0] = side_effect[0] + 1 | 0, /* () */0), (side_effect[0] = side_effect[0] - 1 | 0, /* () */0), 172); + +again4(undefined, (side_effect[0] = side_effect[0] - 1 | 0, /* () */0), 173); + +exports.u = u; +exports.v_ice_cream3 = v_ice_cream3; +exports.v_ice_cream4 = v_ice_cream4; +exports.vv = vv; +exports.int_expect = int_expect; +exports.int_expect2 = int_expect2; +exports.int_expects = int_expects; +exports.mk_ice = mk_ice; +exports.my_ice2 = my_ice2; +exports.my_ice3 = my_ice3; +exports.v_mk4 = v_mk4; +exports.v_mk5 = v_mk5; +exports.v_mk6 = v_mk6; +exports.v_mk6_1 = v_mk6_1; +exports.mk_u = mk_u; +exports.v_mk7 = v_mk7; +exports.side_effect = side_effect; +/* u Not a pure module */ diff --git a/jscomp/test/gpr_1072.ml b/jscomp/test/gpr_1072.ml new file mode 100644 index 0000000000..610d339f28 --- /dev/null +++ b/jscomp/test/gpr_1072.ml @@ -0,0 +1,182 @@ + +(* +external ice_cream: + ?flavor:([`vanilla | `chocolate ] [@bs.string]) -> + num:int -> + unit -> + _ = "" +[@@bs.obj] + + +let my_scoop = ice_cream ~flavor:`vanilla ~num:3 () +*) +(* +external ice_cream_2: + flavor:([`vanilla | `chocolate ] [@bs.string]) -> + num:int -> + unit -> + _ = "" +[@@bs.obj] + +let my_scoop2 = ice_cream_2 ~flavor:`vanilla ~num:3 () +*) + + + +type opt_test = < x : int Js.Undefined.t ; y : int Js.Undefined.t> Js.t +external opt_test : ?x:int -> ?y:int -> unit -> _ = "" +[@@bs.obj] + + +let u : opt_test = opt_test ~y:3 () + + + +external ice_cream3: + ?flavor:([`vanilla | `chocolate [@bs.as "x"]] [@bs.string]) -> + num:int -> + unit -> + _ = "" +[@@bs.obj] (* TODO: warn when [_] happens in any place except `bs.obj` *) +type ice_cream3_expect = < flavor: string Js.undefined ; num : int > Js.t + +let v_ice_cream3 : ice_cream3_expect list = + [ ice_cream3 ~flavor:`vanilla ~num:3 (); + ice_cream3 ~flavor:`chocolate ~num:3 (); + ice_cream3 ~flavor:`vanilla ~num:3 ()] + +type u +external ice_cream4: + ?flavor:([`vanilla | `chocolate [@bs.as "x"]] [@bs.string]) -> + num:int -> + unit -> + u = "" +[@@bs.obj] + +let v_ice_cream4 : u list = + [ ice_cream4 ~flavor:`vanilla ~num:3 (); + ice_cream4 ~flavor:`chocolate ~num:3 ();] + + +external label_test : x_ignore:int -> unit -> _ = "" [@@bs.obj] + +(** here the type label should be the same, + when get the object, it will be mangled *) +type label_expect = < x_ignore : int > Js.t + +let vv : label_expect = label_test ~x_ignore:3 () + + + + +external int_test : x_ignore:([`a|`b] [@bs.int]) -> unit -> _ = "" [@@bs.obj] +(* translate [`a] to 0, [`b] to 1 *) +type int_expect = < x_ignore : int > Js.t + +let int_expect : int_expect = int_test ~x_ignore:`a () + +external int_test2 : ?x_ignore:([`a|`b] [@bs.int]) -> unit -> _ = "" [@@bs.obj] + +type int_expect2 = < x_ignore : int Js.Undefined.t > Js.t + +let int_expect2 : int_expect2 = int_test2 ~x_ignore:`a () + +external int_test3 : ?x_ignore:([`a [@bs.as 2] |`b] [@bs.int]) -> unit -> _ = "" [@@bs.obj] + + +let int_expects : int_expect2 list = + [ int_test3 () ; int_test3 ~x_ignore:`a () ; int_test3 ~x_ignore:`b ()] + + + +external ice : + flavour:([`vanilla | `chocolate] [@bs.string]) -> + num:int -> unit -> + _ = + "" [@@bs.obj] + +let mk_ice : < flavour : string ; num : int > Js.t = + ice ~flavour:`vanilla ~num:3 () + +external ice2 : + ?flavour:([`vanilla | `chocolate] [@bs.string]) -> + num:int -> unit -> + _ = + "" [@@bs.obj] + +let my_ice2 : < flavour : string Js.Undefined.t ; num : int > Js.t = ice2 ~flavour:`vanilla ~num:1 () + +let my_ice3 : < flavour : string Js.Undefined.t ; num : int > Js.t = ice2 ~num:2 () + + +external mk4:x_ignore:([`a|`b][@bs.ignore]) -> y:int -> unit -> _ = "" [@@bs.obj] + +let v_mk4 : < y: int > Js.t = mk4 ~x_ignore:`a ~y:3 () + +external mk5: x:unit -> y:int -> unit -> _ = "" [@@bs.obj] + +let v_mk5 : < x :unit ; y: int > Js.t = mk5 ~x:() ~y:3 () + +external mk6: ?x:unit -> y:int -> unit -> _ = "" [@@bs.obj] + +let v_mk6 : < x : unit Js.Undefined.t ; y : int > Js.t = mk6 ~y:3 () + +let v_mk6_1 = mk6 ~x:() ~y:3 () + +external mk : ?x_ignore:([`a|`b] [@bs.int]) -> unit -> _ = "" [@@bs.val] + + + +(* TODO: fix me *) +let mk_u : Js.t = mk ~x_ignore:`a () + +external mk7 : ?x:([`a|`b][@bs.ignore]) -> y:int -> unit -> _ = "" [@@bs.obj] + +let v_mk7 : < y : int > Js.t list = [ + mk7 ~x:`a ~y:3 (); + mk7 ~x:`b ~y:2 () ; + mk7 ~y:2 () +] + + +external again : ?x_ignore:([`a|`b][@bs.string]) -> int -> unit = "" [@@bs.val] + +let () = + again ~x_ignore:`a 3 ; + again 3 ; + again ?x_ignore:None 3 ; + again ?x_ignore:(ignore 3 ; None) 3 + +external again2 : x_ignore:([`a|`b][@bs.string]) -> int -> unit = "" [@@bs.val] + +let () = + again2 ~x_ignore:`a 3 + +external again3 : x_ignore:([`a|`b][@bs.ignore]) -> int -> unit = "" [@@bs.val] + +let () = + again3 ~x_ignore:`a 3; + again3 ~x_ignore:`b 2; + + +external again4 : ?x:unit -> y:unit -> int -> unit -> unit = "again4" [@@bs.val] + +let side_effect = ref 0 +let () = + again4 ~y:() __LINE__ (); + again4 ?x:None ~y:() __LINE__ (); + again4 ?x:(Some ()) ~y:() __LINE__ (); + again4 ~x:() ~y:() __LINE__(); + again4 ~y:() __LINE__ (); + again4 ~x:(incr side_effect; ()) ~y:() __LINE__ (); + again4 ~x:(incr side_effect; ()) ~y:(decr side_effect; ()) __LINE__ (); + again4 ~y:(decr side_effect; ()) __LINE__ () + + +(* +external again5 : ?x_ignore:([`a of unit -> int | `b of string -> int ] [@bs.string]) + -> int -> unit = "" [@@bs.val] + + let v = again5 3 *) + + \ No newline at end of file diff --git a/jscomp/test/gpr_1072_test.js b/jscomp/test/gpr_1072_test.js deleted file mode 100644 index 5aedde95a1..0000000000 --- a/jscomp/test/gpr_1072_test.js +++ /dev/null @@ -1,15 +0,0 @@ -'use strict'; - - -var my_scoop = { - flavor: /* vanilla */256918907, - num: 3 -}; - -var u = { - y: 3 -}; - -exports.my_scoop = my_scoop; -exports.u = u; -/* my_scoop Not a pure module */ diff --git a/jscomp/test/gpr_1072_test.ml b/jscomp/test/gpr_1072_test.ml deleted file mode 100644 index 172349d27f..0000000000 --- a/jscomp/test/gpr_1072_test.ml +++ /dev/null @@ -1,30 +0,0 @@ - - -external ice_cream: - ?flavor:([`vanilla | `chocolate ] [@bs.string]) -> - num:int -> - unit -> - _ = "" -[@@bs.obj] - - -let my_scoop = ice_cream ~flavor:`vanilla ~num:3 () - -(* -external ice_cream_2: - flavor:([`vanilla | `chocolate ] [@bs.string]) -> - num:int -> - unit -> - _ = "" -[@@bs.obj] - -let my_scoop2 = ice_cream_2 ~flavor:`vanilla ~num:3 () -*) - -type opt_test = < x : int Js.Undefined.t ; y : int Js.Undefined.t> Js.t -external opt_test : ?x:int -> ?y:int -> unit -> _ = "" -[@@bs.obj] - - -let u : opt_test = opt_test ~y:3 () -