diff --git a/docs/Manual.html b/docs/Manual.html
index b1bfc4b3d7..8d04a1b833 100644
--- a/docs/Manual.html
+++ b/docs/Manual.html
@@ -679,6 +679,7 @@ A real world example of using bsb
Build using Make
+Customize rules (generators support, @since 1.7.4)
FAQ
@@ -5086,6 +5087,61 @@ Build
Now in your working directory, type watchman -j < build.json and enjoy the lightning build speed.
+
+
Customize rules (generators support, @since 1.7.4)
+
+
It is quite common that programmers use some pre-processors to generate some bolierpolate code during developement.
+
+
+
Note pre-processors can be classified as two categories, one is system-dependent which should be delayed until running on user machines, the other is system-indepdent , lex, yacc, m4, re2c, etc, which could be executed anytime.
+
+
+
BuckleScript has built in support for conditional compilation, this section is about the second part, since it is system-indepdent, we ask users to always generate such code and check in before shipping, this would help cut the dependencies for end users.
+
+
+
A typical example would be like this
+
+
+
Bsb using ocamlyacc
+
+
{
+ "generators" : [
+ { "name" : "ocamlyacc" ,
+ "command" : "ocamlyacc $in" }
+ ],
+ ...,
+ "sources" : {
+ "dir" : "src",
+ "generators" : [
+ {
+ "name" : "ocamlyacc",
+ "edge" : ["test.ml", "test.mli", ":", "test.mly"]
+ }
+ ]
+ }
+}
+
+
+
+
Note ocamlyacc will generate in test.ml and test.mli in the same directory with test.mly, user should check in generated file since then users would not need run ocamlyacc again, this would apply to menhir as well.
+
+
+
When users are developing current project, bsb will track the dependencies between test.ml and test.mly properly, when released
+as a package, bsb will cut such dependency, so that users will
+only need the generated test.ml, to help test such behavior in development mode, users could set it manually
+
+
+
+
{
+ ...,
+ "cut-generators" : true
+}
+
+
+
+
Then bsb will not re-generate test.ml whenever test.mly changes.
+
+
diff --git a/docs/docson/build-schema.json b/docs/docson/build-schema.json
index 84d440727b..c417226871 100644
--- a/docs/docson/build-schema.json
+++ b/docs/docson/build-schema.json
@@ -303,6 +303,10 @@
},
"description": "(WIP) Pre defined rules"
},
+ "cut-generators" : {
+ "type": "boolean",
+ "description": "Ignore generators, cut the dependency on generator tools"
+ },
"reason": {
"$ref": "#/definitions/reason-specs",
"description": "BuckleScript comes with [Reason](http://facebook.github.io/reason/) by default. Specific configurations here."
diff --git a/jscomp/Makefile b/jscomp/Makefile
index 81920c4e0a..f471e57edf 100644
--- a/jscomp/Makefile
+++ b/jscomp/Makefile
@@ -207,6 +207,7 @@ EXT_SRCS = ext_util\
ext_sexp\
ext_json_types\
ext_json_parse\
+ ext_json_write\
ext_json\
ident_hash_set\
hash_set_poly\
diff --git a/jscomp/all.depend b/jscomp/all.depend
index 727cce921a..8f70c3f425 100644
--- a/jscomp/all.depend
+++ b/jscomp/all.depend
@@ -76,8 +76,10 @@ ext/ext_sexp.cmx : ext/ext_sexp.cmi
ext/ext_json_types.cmx : ext/string_map.cmx
ext/ext_json_parse.cmx : ext/string_map.cmx ext/ext_position.cmx \
ext/ext_json_types.cmx ext/ext_array.cmx ext/ext_json_parse.cmi
+ext/ext_json_write.cmx : ext/string_map.cmx ext/ext_json_types.cmx \
+ ext/ext_json_write.cmi
ext/ext_json.cmx : ext/string_map.cmx ext/ext_json_types.cmx \
- ext/ext_json.cmi
+ ext/ext_array.cmx ext/ext_json.cmi
ext/ident_hash_set.cmx : ext/hash_set_gen.cmx ext/ext_ident.cmx \
stubs/bs_hash_stubs.cmx ext/ident_hash_set.cmi
ext/hash_set_poly.cmx : ext/hash_set_gen.cmx ext/hash_set_poly.cmi
@@ -138,6 +140,7 @@ ext/ext_pp_scope.cmi : ext/ident_set.cmi
ext/ext_io.cmi :
ext/ext_sexp.cmi :
ext/ext_json_parse.cmi : ext/ext_json_types.cmx
+ext/ext_json_write.cmi : ext/ext_json_types.cmx
ext/ext_json.cmi : ext/string_map.cmi ext/ext_position.cmi \
ext/ext_json_types.cmx
ext/ident_hash_set.cmi : ext/hash_set_gen.cmx
@@ -154,8 +157,8 @@ common/bs_warnings.cmx : ext/literals.cmx common/js_config.cmx \
common/bs_warnings.cmi
common/lam_methname.cmx : ext/string_hash_set.cmx ext/ext_string.cmx \
common/lam_methname.cmi
-common/binary_cache.cmx : ext/string_map.cmx ext/ext_filename.cmx \
- common/binary_cache.cmi
+common/binary_cache.cmx : ext/string_map.cmx ext/ext_string.cmx \
+ ext/ext_filename.cmx common/binary_cache.cmi
common/bs_version.cmi :
common/js_config.cmi :
common/ext_log.cmi :
@@ -655,7 +658,8 @@ ounit_tests/ounit_scc_tests.cmx : ext/string_hashtbl.cmx ounit/oUnit.cmx \
ext/int_vec_vec.cmx ext/int_vec.cmx ext/ext_string.cmx ext/ext_scc.cmx
ounit_tests/ounit_hashtbl_tests.cmx : ext/string_hashtbl.cmx ounit/oUnit.cmx
ounit_tests/ounit_json_tests.cmx : ext/string_map.cmx ounit/oUnit.cmx \
- ext/ext_json_types.cmx ext/ext_json_parse.cmx ext/ext_json.cmx
+ ext/ext_pervasives.cmx ext/ext_json_write.cmx ext/ext_json_types.cmx \
+ ext/ext_json_parse.cmx ext/ext_json.cmx
ounit_tests/ounit_map_tests.cmx : ounit/oUnit.cmx ext/int_map.cmx
ounit_tests/ounit_ordered_hash_set_tests.cmx : \
ext/ordered_hash_set_string.cmx ounit/oUnit.cmx ext/ext_util.cmx \
@@ -706,8 +710,8 @@ 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_types.cmx \
ext/ext_json.cmx ext/ext_filename.cmx ext/ext_file_pp.cmx \
- bsb/bsb_exception.cmx bsb/bsb_build_util.cmx bsb/bsb_build_schemas.cmx \
- common/binary_cache.cmx bsb/bsb_build_ui.cmi
+ ext/ext_array.cmx bsb/bsb_exception.cmx bsb/bsb_build_util.cmx \
+ bsb/bsb_build_schemas.cmx common/binary_cache.cmx bsb/bsb_build_ui.cmi
bsb/bsb_build_util.cmx : ext/string_map.cmx ext/string_hashtbl.cmx \
ext/literals.cmx ext/ext_sys.cmx ext/ext_string.cmx ext/ext_list.cmx \
ext/ext_json_types.cmx ext/ext_json_parse.cmx ext/ext_json.cmx \
@@ -720,11 +724,12 @@ bsb/bsb_config_parse.cmx : ext/string_set.cmx ext/string_map.cmx \
ext/string_hash_set.cmx ext/literals.cmx ext/ext_string.cmx \
ext/ext_json_types.cmx ext/ext_json_parse.cmx ext/ext_json.cmx \
ext/ext_filename.cmx ext/ext_file_pp.cmx ext/ext_array.cmx \
- bsb/bsb_pkg.cmx bsb/bsb_default.cmx bsb/bsb_config_types.cmx \
- bsb/bsb_config.cmx bsb/bsb_build_util.cmx bsb/bsb_build_ui.cmx \
- bsb/bsb_build_schemas.cmx common/bs_version.cmx bsb/bsb_config_parse.cmi
-bsb/bsb_config_types.cmx : ext/string_hash_set.cmx bsb/bsb_config.cmx \
- bsb/bsb_build_ui.cmx
+ bsb/bsb_pkg.cmx bsb/bsb_exception.cmx bsb/bsb_default.cmx \
+ bsb/bsb_config_types.cmx bsb/bsb_config.cmx bsb/bsb_build_util.cmx \
+ bsb/bsb_build_ui.cmx bsb/bsb_build_schemas.cmx common/bs_version.cmx \
+ bsb/bsb_config_parse.cmi
+bsb/bsb_config_types.cmx : ext/string_map.cmx ext/string_hash_set.cmx \
+ bsb/bsb_config.cmx bsb/bsb_build_ui.cmx
bsb/bsb_default.cmx : ext/string_set.cmx ext/literals.cmx \
bsb/bsb_config_types.cmx bsb/bsb_default.cmi
bsb/bsb_dep_infos.cmx : common/bs_version.cmx bsb/bsb_dep_infos.cmi
@@ -760,14 +765,15 @@ bsb/bsb_main.cmx : ext/string_hash_set.cmx ext/literals.cmx ext/ext_sys.cmx \
bsb/bsb_main.cmi
bsb/bsb_ninja.cmx : ext/string_set.cmx ext/string_map.cmx \
ext/string_hash_set.cmx ext/literals.cmx ext/ext_string.cmx \
- ext/ext_filename.cmx bsb/bsb_rule.cmx bsb/bsb_config.cmx \
- bsb/bsb_build_util.cmx bsb/bsb_build_ui.cmx bsb/bsb_build_schemas.cmx \
- common/binary_cache.cmx bsb/bsb_ninja.cmi
+ ext/ext_pervasives.cmx ext/ext_filename.cmx bsb/bsb_rule.cmx \
+ bsb/bsb_config.cmx bsb/bsb_build_util.cmx bsb/bsb_build_ui.cmx \
+ bsb/bsb_build_schemas.cmx common/binary_cache.cmx bsb/bsb_ninja.cmi
bsb/bsb_os_dependent.cmx :
bsb/bsb_pkg.cmx : ext/string_hashtbl.cmx ext/literals.cmx \
bsb/bsb_exception.cmx bsb/bsb_pkg.cmi
bsb/bsb_regex.cmx : bsb/bsb_regex.cmi
-bsb/bsb_rule.cmx : ext/string_set.cmx ext/ext_sys.cmx bsb/bsb_rule.cmi
+bsb/bsb_rule.cmx : ext/string_set.cmx ext/string_map.cmx ext/ext_sys.cmx \
+ bsb/bsb_rule.cmi
bsb/bsb_templates.cmx : bsb/oCamlRes.cmx bsb/bsb_templates.cmi
bsb/bsb_unix.cmx : ext/ext_sys.cmx ext/ext_string.cmx bsb/bsb_unix.cmi
bsb/oCamlRes.cmx :
@@ -789,11 +795,11 @@ bsb/bsb_helper_main.cmi :
bsb/bsb_helper_packer.cmi :
bsb/bsb_init.cmi :
bsb/bsb_main.cmi :
-bsb/bsb_ninja.cmi : ext/string_hash_set.cmi bsb/bsb_rule.cmi \
- bsb/bsb_config.cmi bsb/bsb_build_ui.cmi
+bsb/bsb_ninja.cmi : ext/string_map.cmi ext/string_hash_set.cmi \
+ bsb/bsb_rule.cmi bsb/bsb_config.cmi bsb/bsb_build_ui.cmi
bsb/bsb_pkg.cmi :
bsb/bsb_regex.cmi :
-bsb/bsb_rule.cmi :
+bsb/bsb_rule.cmi : ext/string_map.cmi
bsb/bsb_templates.cmi : bsb/oCamlRes.cmx
bsb/bsb_unix.cmi :
jscmj_main.cmx : common/js_config.cmx core/js_cmj_format.cmx \
diff --git a/jscomp/bin/all_ounit_tests.d b/jscomp/bin/all_ounit_tests.d
index ce254a2e26..c1f1c2b85d 100644
--- a/jscomp/bin/all_ounit_tests.d
+++ b/jscomp/bin/all_ounit_tests.d
@@ -71,11 +71,13 @@ bin/all_ounit_tests.ml : ext/resize_array.mli
bin/all_ounit_tests.ml : ounit/oUnitLogger.ml
bin/all_ounit_tests.ml : ext/ext_json_parse.ml
bin/all_ounit_tests.ml : ext/ext_json_types.ml
+bin/all_ounit_tests.ml : ext/ext_json_write.ml
bin/all_ounit_tests.ml : ext/ext_pervasives.ml
bin/all_ounit_tests.ml : ext/hash_set_poly.mli
bin/all_ounit_tests.ml : ext/string_hashtbl.ml
bin/all_ounit_tests.ml : ounit/oUnitChooser.ml
bin/all_ounit_tests.ml : ext/ext_json_parse.mli
+bin/all_ounit_tests.ml : ext/ext_json_write.mli
bin/all_ounit_tests.ml : ext/ext_pervasives.mli
bin/all_ounit_tests.ml : ext/string_hash_set.ml
bin/all_ounit_tests.ml : ext/string_hashtbl.mli
diff --git a/jscomp/bin/all_ounit_tests.i.ml b/jscomp/bin/all_ounit_tests.i.ml
index a5d13a22e9..113e1f2588 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 =
- (* 201 *) List.hd state.tests_planned
+ (* 206 *) 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 _ -> (* 402 *) false
+ | RSuccess _ | RError _ | RSkip _ | RTodo _ -> (* 412 *) false
let is_error =
function
| RError _ -> (* 0 *) true
- | RSuccess _ | RFailure _ | RSkip _ | RTodo _ -> (* 402 *) false
+ | RSuccess _ | RFailure _ | RSkip _ | RTodo _ -> (* 412 *) false
let is_skip =
function
| RSkip _ -> (* 0 *) true
- | RSuccess _ | RFailure _ | RError _ | RTodo _ -> (* 402 *) false
+ | RSuccess _ | RFailure _ | RError _ | RTodo _ -> (* 412 *) false
let is_todo =
function
| RTodo _ -> (* 0 *) true
- | RSuccess _ | RFailure _ | RError _ | RSkip _ -> (* 402 *) false
+ | RSuccess _ | RFailure _ | RError _ | RSkip _ -> (* 412 *) false
let result_flavour =
function
@@ -145,7 +145,7 @@ let rec was_successful =
| [] -> (* 3 *) true
| RSuccess _::t
| RSkip _::t ->
- (* 603 *) was_successful t
+ (* 618 *) was_successful t
| RFailure _::_
| RError _::_
@@ -155,22 +155,22 @@ let rec was_successful =
let string_of_node =
function
| ListItem n ->
- (* 804 *) string_of_int n
+ (* 824 *) string_of_int n
| Label s ->
- (* 1206 *) s
+ (* 1236 *) s
(* Return the number of available tests *)
let rec test_case_count =
function
- | TestCase _ -> (* 201 *) 1
- | TestLabel (_, t) -> (* 226 *) test_case_count t
+ | TestCase _ -> (* 206 *) 1
+ | TestLabel (_, t) -> (* 231 *) test_case_count t
| TestList l ->
(* 25 *) List.fold_left
- (fun c t -> (* 225 *) c + test_case_count t)
+ (fun c t -> (* 230 *) c + test_case_count t)
0 l
let string_of_path path =
- (* 402 *) String.concat ":" (List.rev_map string_of_node path)
+ (* 412 *) String.concat ":" (List.rev_map string_of_node path)
let buff_format_printf f =
(* 0 *) let buff = Buffer.create 13 in
@@ -194,12 +194,12 @@ let mapi f l =
let fold_lefti f accu l =
(* 25 *) let rec rfold_lefti cnt accup l =
- (* 250 *) match l with
+ (* 255 *) match l with
| [] ->
(* 25 *) accup
| h::t ->
- (* 225 *) rfold_lefti (cnt + 1) (f accup h cnt) t
+ (* 230 *) 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 =
- (* 1208 *) match event_type with
+ (* 1238 *) match event_type with
| GlobalEvent e ->
(* 2 *) begin
match e with
@@ -276,31 +276,31 @@ let format_event verbose event_type =
end
| TestEvent e ->
- (* 1206 *) begin
+ (* 1236 *) begin
let string_of_result =
if verbose then
- (* 603 *) function
- | RSuccess _ -> (* 201 *) "ok\n"
+ (* 618 *) function
+ | RSuccess _ -> (* 206 *) "ok\n"
| RFailure (_, _) -> (* 0 *) "FAIL\n"
| RError (_, _) -> (* 0 *) "ERROR\n"
| RSkip (_, _) -> (* 0 *) "SKIP\n"
| RTodo (_, _) -> (* 0 *) "TODO\n"
else
- (* 603 *) function
- | RSuccess _ -> (* 201 *) "."
+ (* 618 *) function
+ | RSuccess _ -> (* 206 *) "."
| RFailure (_, _) -> (* 0 *) "F"
| RError (_, _) -> (* 0 *) "E"
| RSkip (_, _) -> (* 0 *) "S"
| RTodo (_, _) -> (* 0 *) "T"
in
if verbose then
- (* 603 *) match e with
+ (* 618 *) match e with
| EStart p ->
- (* 201 *) Printf.sprintf "%s start\n" (string_of_path p)
+ (* 206 *) Printf.sprintf "%s start\n" (string_of_path p)
| EEnd p ->
- (* 201 *) Printf.sprintf "%s end\n" (string_of_path p)
+ (* 206 *) Printf.sprintf "%s end\n" (string_of_path p)
| EResult result ->
- (* 201 *) string_of_result result
+ (* 206 *) 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
- (* 603 *) match e with
- | EStart _ | EEnd _ | ELog _ | ELogRaw _ -> (* 402 *) ""
- | EResult result -> (* 201 *) string_of_result result
+ (* 618 *) match e with
+ | EStart _ | EEnd _ | ELog _ | ELogRaw _ -> (* 412 *) ""
+ | EResult result -> (* 206 *) string_of_result result
end
let file_logger fn =
(* 1 *) let chn = open_out fn in
(fun ev ->
- (* 604 *) output_string chn (format_event true ev);
+ (* 619 *) output_string chn (format_event true ev);
flush chn),
(fun () -> (* 1 *) close_out chn)
let std_logger verbose =
(* 1 *) (fun ev ->
- (* 604 *) print_string (format_event verbose ev);
+ (* 619 *) 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 ->
- (* 604 *) std_log ev; file_log ev; log ev),
+ (* 619 *) std_log ev; file_log ev; log ev),
(fun () ->
(* 1 *) std_close (); file_close (); close ())
@@ -705,13 +705,13 @@ let assert_failure msg =
(* 0 *) failwith ("OUnit: " ^ msg)
let assert_bool msg b =
- (* 2009445 *) if not b then (* 0 *) assert_failure msg
+ (* 2009455 *) if not b then (* 0 *) assert_failure msg
let assert_string str =
(* 0 *) if not (str = "") then (* 0 *) assert_failure str
let assert_equal ?(cmp = ( = )) ?printer ?pp_diff ?msg expected actual =
- (* 2001542 *) let get_error_string () =
+ (* 2001548 *) let get_error_string () =
(* 0 *) let res =
buff_format_printf
(fun fmt ->
@@ -951,7 +951,7 @@ let (@?) = assert_bool
(* Some shorthands which allows easy test construction *)
let (>:) s t = (* 0 *) TestLabel(s, t) (* infix *)
-let (>::) s f = (* 201 *) TestLabel(s, TestCase(f)) (* infix *)
+let (>::) s f = (* 206 *) TestLabel(s, TestCase(f)) (* infix *)
let (>:::) s l = (* 25 *) TestLabel(s, TestList(l)) (* infix *)
(* Utility function to manipulate test *)
@@ -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 =
- (* 201 *) try
+ (* 206 *) try
f ();
RSuccess path
with
@@ -1106,22 +1106,22 @@ let perform_test report test =
let rec flatten_test path acc =
function
| TestCase(f) ->
- (* 201 *) (path, f) :: acc
+ (* 206 *) (path, f) :: acc
| TestList (tests) ->
(* 25 *) fold_lefti
(fun acc t cnt ->
- (* 225 *) flatten_test
+ (* 230 *) flatten_test
((ListItem cnt)::path)
acc t)
acc tests
| TestLabel (label, t) ->
- (* 226 *) flatten_test ((Label label)::path) acc t
+ (* 231 *) flatten_test ((Label label)::path) acc t
in
let test_cases = List.rev (flatten_test [] [] test) in
let runner (path, f) =
- (* 201 *) let result =
+ (* 206 *) 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 =
- (* 202 *) match state.tests_planned with
+ (* 207 *) match state.tests_planned with
| [] ->
(* 1 *) state.results
| _ ->
- (* 201 *) let (path, f) = !global_chooser state in
+ (* 206 *) let (path, f) = !global_chooser state in
let result = runner (path, f) in
iter
{
results = result :: state.results;
tests_planned =
List.filter
- (fun (path', _) -> (* 20301 *) path <> path') state.tests_planned
+ (fun (path', _) -> (* 21321 *) 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 ->
- (* 603 *) log (OUnitLogger.TestEvent ev))
+ (* 618 *) log (OUnitLogger.TestEvent ev))
test
in
@@ -1320,6 +1320,12 @@ val find_and_split :
val exists : ('a -> bool) -> 'a array -> bool
val is_empty : 'a array -> bool
+
+val for_all2_no_exn :
+ ('a -> 'b -> bool) ->
+ 'a array ->
+ 'b array ->
+ bool
end = struct
#1 "ext_array.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
@@ -1373,13 +1379,13 @@ let reverse a =
b
let reverse_of_list = function
- | [] -> (* 1 *) [||]
+ | [] -> (* 5 *) [||]
| hd::tl as l ->
- (* 2 *) let len = List.length l in
+ (* 14 *) let len = List.length l in
let a = Array.make len hd in
let rec fill i = function
- | [] -> (* 2 *) a
- | hd::tl -> (* 2 *) Array.unsafe_set a (len - i - 2) hd; fill (i+1) tl in
+ | [] -> (* 14 *) a
+ | hd::tl -> (* 38 *) Array.unsafe_set a (len - i - 2) hd; fill (i+1) tl in
fill 0 tl
let filter f a =
@@ -1508,6 +1514,21 @@ let exists p a =
let is_empty arr =
(* 0 *) Array.length arr = 0
+
+
+let rec unsafe_loop index len p xs ys =
+ (* 24 *) if index >= len then (* 6 *) true
+ else
+ (* 18 *) p
+ (Array.unsafe_get xs index)
+ (Array.unsafe_get ys index) &&
+ unsafe_loop (succ index) len p xs ys
+
+let for_all2_no_exn p xs ys =
+ (* 8 *) let len_xs = Array.length xs in
+ let len_ys = Array.length ys in
+ len_xs = len_ys &&
+ unsafe_loop 0 len_xs p xs ys
end
module Ext_bytes : sig
#1 "ext_bytes.mli"
@@ -1873,15 +1894,15 @@ let starts_with s beg =
end with [beg]
*)
let ends_with_index s end_ =
- (* 63 *) let s_finish = String.length s - 1 in
+ (* 53 *) let s_finish = String.length s - 1 in
let s_beg = String.length end_ - 1 in
if s_beg > s_finish then (* 0 *) -1
else
- (* 63 *) let rec aux j k =
- (* 159 *) if k < 0 then (* 27 *) (j + 1)
- else (* 132 *) if String.unsafe_get s j = String.unsafe_get end_ k then
- (* 96 *) aux (j - 1) (k - 1)
- else (* 36 *) -1 in
+ (* 53 *) let rec aux j k =
+ (* 144 *) if k < 0 then (* 26 *) (j + 1)
+ else (* 118 *) if String.unsafe_get s j = String.unsafe_get end_ k then
+ (* 91 *) aux (j - 1) (k - 1)
+ else (* 27 *) -1 in
aux s_finish s_beg
let ends_with s end_ = (* 0 *) ends_with_index s end_ >= 0
@@ -1898,13 +1919,13 @@ let check_any_suffix_case s suffixes =
(* 0 *) List.exists (fun x -> (* 0 *) check_suffix_case s x) suffixes
let check_any_suffix_case_then_chop s suffixes =
- (* 27 *) let rec aux suffixes =
- (* 62 *) match suffixes with
+ (* 26 *) let rec aux suffixes =
+ (* 52 *) match suffixes with
| [] -> (* 1 *) None
| x::xs ->
- (* 61 *) let id = ends_with_index s x in
- if id >= 0 then (* 26 *) Some (String.sub s 0 id)
- else (* 35 *) aux xs in
+ (* 51 *) let id = ends_with_index s x in
+ if id >= 0 then (* 25 *) Some (String.sub s 0 id)
+ else (* 26 *) aux xs in
aux suffixes
@@ -1931,7 +1952,7 @@ let escaped s =
*)
let rec unsafe_for_all_range s ~start ~finish p =
- (* 154 *) start > finish ||
+ (* 153 *) start > finish ||
p (String.unsafe_get s start) &&
unsafe_for_all_range s ~start:(start + 1) ~finish p
@@ -2098,12 +2119,12 @@ let rindex_opt s c =
(* 0 *) rindex_rec_opt s (String.length s - 1) c;;
let is_valid_module_file (s : string) =
- (* 26 *) let len = String.length s in
+ (* 25 *) let len = String.length s in
len > 0 &&
match String.unsafe_get s 0 with
| 'A' .. 'Z'
| 'a' .. 'z' ->
- (* 12 *) unsafe_for_all_range s ~start:1 ~finish:(len - 1)
+ (* 11 *) unsafe_for_all_range s ~start:1 ~finish:(len - 1)
(fun x ->
(* 9 *) match x with
| 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> (* 7 *) true
@@ -2140,15 +2161,16 @@ type check_result =
Make {!Ext_filename} not stateful
*)
let is_valid_source_name name : check_result =
- (* 27 *) match check_any_suffix_case_then_chop name [
+ (* 26 *) match check_any_suffix_case_then_chop name [
".ml";
".re";
- ".mli"; ".mll"; ".rei"
+ ".mli";
+ ".rei"
] with
| None -> (* 1 *) Suffix_mismatch
| Some x ->
- (* 26 *) if is_valid_module_file x then
- (* 10 *) Good
+ (* 25 *) if is_valid_module_file x then
+ (* 9 *) Good
else (* 16 *) Invalid_module_name
(** TODO: can be improved to return a positive integer instead *)
@@ -2342,6 +2364,34 @@ let suites =
[|1;2;3;4;5;6|] []
=~ [2;4;6]
end;
+
+ __LOC__ >:: begin fun _ ->
+ (* 1 *) OUnit.assert_bool __LOC__
+ (Ext_array.for_all2_no_exn
+ (=)
+ [|1;2;3|]
+ [|1;2;3|]
+ )
+ end;
+ __LOC__ >:: begin fun _ ->
+ (* 1 *) OUnit.assert_bool __LOC__
+ (Ext_array.for_all2_no_exn
+ (=) [||] [||]
+ );
+ OUnit.assert_bool __LOC__
+ (not @@ Ext_array.for_all2_no_exn
+ (=) [||] [|1|]
+ )
+ end
+ ;
+ __LOC__ >:: begin fun _ ->
+ (* 1 *) OUnit.assert_bool __LOC__
+ (not (Ext_array.for_all2_no_exn
+ (=)
+ [|1;2;3|]
+ [|1;2;33|]
+ ))
+ end
]
end
module Ounit_tests_util
@@ -7944,9 +7994,9 @@ let keys s = (* 1 *) keys_aux [] s
let rec cons_enum m e =
- (* 0 *) match m with
- Empty -> (* 0 *) e
- | Node(l, v, d, r, _) -> (* 0 *) cons_enum l (More(v, d, r, e))
+ (* 30 *) match m with
+ Empty -> (* 18 *) e
+ | Node(l, v, d, r, _) -> (* 12 *) cons_enum l (More(v, d, r, e))
let height = function
@@ -7960,8 +8010,8 @@ let create l x d r =
let singleton x d = (* 0 *) Node(Empty, x, d, Empty, 1)
let bal l x d r =
- (* 27932 *) let hl = match l with Empty -> (* 5003 *) 0 | Node(_,_,_,_,h) -> (* 22929 *) h in
- let hr = match r with Empty -> (* 2 *) 0 | Node(_,_,_,_,h) -> (* 27930 *) h in
+ (* 27954 *) let hl = match l with Empty -> (* 5021 *) 0 | Node(_,_,_,_,h) -> (* 22933 *) h in
+ let hr = match r with Empty -> (* 4 *) 0 | Node(_,_,_,_,h) -> (* 27950 *) h in
if hl > hr + 2 then (* 0 *) begin
match l with
Empty -> (* 0 *) invalid_arg "Map.bal"
@@ -7974,7 +8024,7 @@ let bal l x d r =
| Node(lrl, lrv, lrd, lrr, _)->
(* 0 *) create (create ll lv ld lrl) lrv lrd (create lrr x d r)
end
- end else (* 27932 *) if hr > hl + 2 then (* 1980 *) begin
+ end else (* 27954 *) if hr > hl + 2 then (* 1980 *) begin
match r with
Empty -> (* 0 *) invalid_arg "Map.bal"
| Node(rl, rv, rd, rr, _) ->
@@ -7987,11 +8037,11 @@ let bal l x d r =
(* 0 *) create (create l x d rll) rlv rld (create rlr rv rd rr)
end
end else
- (* 25952 *) Node(l, x, d, r, (if hl >= hr then (* 6082 *) hl + 1 else (* 19870 *) hr + 1))
+ (* 25974 *) Node(l, x, d, r, (if hl >= hr then (* 6086 *) hl + 1 else (* 19888 *) hr + 1))
let empty = Empty
-let is_empty = function Empty -> (* 1 *) true | _ -> (* 0 *) false
+let is_empty = function Empty -> (* 4 *) true | _ -> (* 6 *) false
let rec min_binding_exn = function
Empty -> (* 0 *) raise Not_found
@@ -8043,10 +8093,10 @@ let rec mapi f = function
Node(l', v, d', r', h)
let rec fold f m accu =
- (* 0 *) match m with
- Empty -> (* 0 *) accu
+ (* 42 *) match m with
+ Empty -> (* 24 *) accu
| Node(l, v, d, r, _) ->
- (* 0 *) fold f r (f v d (fold f l accu))
+ (* 18 *) fold f r (f v d (fold f l accu))
let rec for_all p = function
Empty -> (* 0 *) true
@@ -8138,13 +8188,13 @@ let compare compare_key cmp_val m1 m2 =
in compare_aux (cons_enum m1 End) (cons_enum m2 End)
let equal compare_key cmp m1 m2 =
- (* 0 *) let rec equal_aux e1 e2 =
- (* 0 *) match (e1, e2) with
- (End, End) -> (* 0 *) true
+ (* 3 *) let rec equal_aux e1 e2 =
+ (* 9 *) match (e1, e2) with
+ (End, End) -> (* 3 *) true
| (End, _) -> (* 0 *) false
| (_, End) -> (* 0 *) false
| (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
- (* 0 *) compare_key v1 v2 = 0 && cmp d1 d2 &&
+ (* 6 *) compare_key v1 v2 = 0 && cmp d1 d2 &&
equal_aux (cons_enum r1 e1) (cons_enum r2 e2)
in equal_aux (cons_enum m1 End) (cons_enum m2 End)
@@ -8343,17 +8393,17 @@ let max_binding_exn = Map_gen.max_binding_exn
let min_binding_exn = Map_gen.min_binding_exn
-let rec add x data (tree : _ Map_gen.t as 'a) : 'a = (* 4 *) match tree with
+let rec add x data (tree : _ Map_gen.t as 'a) : 'a = (* 50 *) match tree with
| Empty ->
- (* 4 *) Node(Empty, x, data, Empty, 1)
+ (* 28 *) Node(Empty, x, data, Empty, 1)
| Node(l, v, d, r, h) ->
- (* 0 *) let c = compare_key x v in
+ (* 22 *) let c = compare_key x v in
if c = 0 then
(* 0 *) Node(l, x, data, r, h)
- else (* 0 *) if c < 0 then
- (* 0 *) bal (add x data l) v d r
+ else (* 22 *) if c < 0 then
+ (* 2 *) bal (add x data l) v d r
else
- (* 0 *) bal l v d (add x data r)
+ (* 20 *) bal l v d (add x data r)
let rec adjust x data replace (tree : _ Map_gen.t as 'a) : 'a =
@@ -8459,7 +8509,7 @@ let rec disjoint_merge (s1 : _ Map_gen.t) (s2 : _ Map_gen.t) : _ Map_gen.t =
let compare cmp m1 m2 = (* 0 *) Map_gen.compare compare_key cmp m1 m2
-let equal cmp m1 m2 = (* 0 *) Map_gen.equal compare_key cmp m1 m2
+let equal cmp m1 m2 = (* 3 *) Map_gen.equal compare_key cmp m1 m2
let add_list (xs : _ list ) init =
(* 0 *) List.fold_left (fun acc (k,v) -> (* 0 *) add k v acc) init xs
@@ -8661,9 +8711,32 @@ val query : path -> Ext_json_types.t -> status
val loc_of : Ext_json_types.t -> Ext_position.t
+val equal : Ext_json_types.t -> Ext_json_types.t -> bool
end = struct
#1 "ext_json.ml"
-
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
type callback =
[
@@ -8679,7 +8752,7 @@ type callback =
| `Id of (Ext_json_types.t -> unit )
]
-
+
type path = string list
type status =
@@ -8689,26 +8762,26 @@ type status =
let test ?(fail=(fun () -> ())) key
(cb : callback) (m : Ext_json_types.t String_map.t)
- =
- (* 2 *) begin match String_map.find_exn key m, cb with
- | exception Not_found ->
- (* 0 *) begin match cb with `Not_found f -> (* 0 *) f ()
- | _ -> (* 0 *) fail ()
- end
- | True _, `Bool cb -> (* 0 *) cb true
- | False _, `Bool cb -> (* 0 *) cb false
- | Flo {flo = s} , `Flo cb -> (* 2 *) cb s
- | Obj {map = b} , `Obj cb -> (* 0 *) cb b
- | Arr {content}, `Arr cb -> (* 0 *) cb content
- | Arr {content; loc_start ; loc_end}, `Arr_loc cb ->
- (* 0 *) cb content loc_start loc_end
- | Null _, `Null cb -> (* 0 *) cb ()
- | Str {str = s }, `Str cb -> (* 0 *) cb s
- | Str {str = s ; loc }, `Str_loc cb -> (* 0 *) cb s loc
- | any , `Id cb -> (* 0 *) cb any
- | _, _ -> (* 0 *) fail ()
- end;
- m
+ =
+ (* 2 *) begin match String_map.find_exn key m, cb with
+ | exception Not_found ->
+ (* 0 *) begin match cb with `Not_found f -> (* 0 *) f ()
+ | _ -> (* 0 *) fail ()
+ end
+ | True _, `Bool cb -> (* 0 *) cb true
+ | False _, `Bool cb -> (* 0 *) cb false
+ | Flo {flo = s} , `Flo cb -> (* 2 *) cb s
+ | Obj {map = b} , `Obj cb -> (* 0 *) cb b
+ | Arr {content}, `Arr cb -> (* 0 *) cb content
+ | Arr {content; loc_start ; loc_end}, `Arr_loc cb ->
+ (* 0 *) cb content loc_start loc_end
+ | Null _, `Null cb -> (* 0 *) cb ()
+ | Str {str = s }, `Str cb -> (* 0 *) cb s
+ | Str {str = s ; loc }, `Str_loc cb -> (* 0 *) cb s loc
+ | any , `Id cb -> (* 0 *) cb any
+ | _, _ -> (* 0 *) fail ()
+ end;
+ m
let query path (json : Ext_json_types.t ) =
(* 0 *) let rec aux acc paths json =
(* 0 *) match path with
@@ -8732,7 +8805,53 @@ let loc_of (x : Ext_json_types.t) =
| Arr p -> (* 0 *) p.loc_start
| Obj p -> (* 0 *) p.loc
| Flo p -> (* 0 *) p.loc
-
+
+
+let rec equal
+ (x : Ext_json_types.t)
+ (y : Ext_json_types.t) =
+ (* 24 *) match x with
+ | Null _ -> (* [%p? Null _ ] *)
+ (* 0 *) begin match y with
+ | Null _ -> (* 0 *) true
+ | _ -> (* 0 *) false end
+ | Str {str } ->
+ (* 4 *) begin match y with
+ | Str {str = str2} -> (* 4 *) str = str2
+ | _ -> (* 0 *) false end
+ | Flo {flo}
+ ->
+ (* 11 *) begin match y with
+ | Flo {flo = flo2} ->
+ (* 11 *) flo = flo2
+ | _ -> (* 0 *) false
+ end
+ | True _ ->
+ (* 1 *) begin match y with
+ | True _ -> (* 1 *) true
+ | _ -> (* 0 *) false
+ end
+ | False _ ->
+ (* 1 *) begin match y with
+ | False _ -> (* 1 *) true
+ | _ -> (* 0 *) false
+ end
+ | Arr {content}
+ ->
+ (* 4 *) begin match y with
+ | Arr {content = content2}
+ ->
+ (* 4 *) Ext_array.for_all2_no_exn equal content content2
+ | _ -> (* 0 *) false
+ end
+
+ | Obj {map} ->
+ (* 3 *) begin match y with
+ | Obj { map = map2} ->
+ (* 3 *) String_map.equal equal map map2
+ | _ -> (* 0 *) false
+ end
+
end
module Ext_json_parse : sig
@@ -8877,7 +8996,7 @@ let lexeme_len (x : Lexing.lexbuf) =
(* 0 *) x.lex_curr_pos - x.lex_start_pos
let update_loc ({ lex_curr_p; _ } as lexbuf : Lexing.lexbuf) diff =
- (* 0 *) lexbuf.lex_curr_p <-
+ (* 4 *) lexbuf.lex_curr_p <-
{
lex_curr_p with
pos_lnum = lex_curr_p.pos_lnum + 1;
@@ -8889,7 +9008,7 @@ let char_for_backslash = function
| 'r' -> (* 0 *) '\013'
| 'b' -> (* 0 *) '\008'
| 't' -> (* 0 *) '\009'
- | c -> (* 0 *) c
+ | c -> (* 4 *) c
let dec_code c1 c2 c3 =
(* 0 *) 100 * (Char.code c1 - 48) + 10 * (Char.code c2 - 48) + (Char.code c3 - 48)
@@ -9093,17 +9212,17 @@ let __ocaml_lex_tables = {
}
let rec lex_json buf lexbuf =
- (* 86 *) __ocaml_lex_lex_json_rec buf lexbuf 0
+ (* 500 *) __ocaml_lex_lex_json_rec buf lexbuf 0
and __ocaml_lex_lex_json_rec buf lexbuf __ocaml_lex_state =
- (* 86 *) match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with
+ (* 500 *) match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with
| 0 ->
# 152 "ext/ext_json_parse.mll"
- (* 31 *) ( lex_json buf lexbuf)
+ (* 193 *) ( lex_json buf lexbuf)
# 324 "ext/ext_json_parse.ml"
| 1 ->
# 153 "ext/ext_json_parse.mll"
- (* 0 *) (
+ (* 4 *) (
update_loc lexbuf 0;
lex_json buf lexbuf
)
@@ -9116,12 +9235,12 @@ and __ocaml_lex_lex_json_rec buf lexbuf __ocaml_lex_state =
| 3 ->
# 158 "ext/ext_json_parse.mll"
- (* 0 *) ( True)
+ (* 4 *) ( True)
# 342 "ext/ext_json_parse.ml"
| 4 ->
# 159 "ext/ext_json_parse.mll"
- (* 0 *) (False)
+ (* 4 *) (False)
# 347 "ext/ext_json_parse.ml"
| 5 ->
@@ -9131,32 +9250,32 @@ and __ocaml_lex_lex_json_rec buf lexbuf __ocaml_lex_state =
| 6 ->
# 161 "ext/ext_json_parse.mll"
- (* 5 *) (Lbracket)
+ (* 21 *) (Lbracket)
# 357 "ext/ext_json_parse.ml"
| 7 ->
# 162 "ext/ext_json_parse.mll"
- (* 3 *) (Rbracket)
+ (* 19 *) (Rbracket)
# 362 "ext/ext_json_parse.ml"
| 8 ->
# 163 "ext/ext_json_parse.mll"
- (* 6 *) (Lbrace)
+ (* 18 *) (Lbrace)
# 367 "ext/ext_json_parse.ml"
| 9 ->
# 164 "ext/ext_json_parse.mll"
- (* 3 *) (Rbrace)
+ (* 15 *) (Rbrace)
# 372 "ext/ext_json_parse.ml"
| 10 ->
# 165 "ext/ext_json_parse.mll"
- (* 13 *) (Comma)
+ (* 65 *) (Comma)
# 377 "ext/ext_json_parse.ml"
| 11 ->
# 166 "ext/ext_json_parse.mll"
- (* 4 *) (Colon)
+ (* 28 *) (Colon)
# 382 "ext/ext_json_parse.ml"
| 12 ->
@@ -9166,12 +9285,12 @@ and __ocaml_lex_lex_json_rec buf lexbuf __ocaml_lex_state =
| 13 ->
# 169 "ext/ext_json_parse.mll"
- (* 11 *) ( Number (Lexing.lexeme lexbuf))
+ (* 55 *) ( Number (Lexing.lexeme lexbuf))
# 392 "ext/ext_json_parse.ml"
| 14 ->
# 171 "ext/ext_json_parse.mll"
- (* 4 *) (
+ (* 44 *) (
let pos = Lexing.lexeme_start_p lexbuf in
scan_string buf pos lexbuf;
let content = (Buffer.contents buf) in
@@ -9182,7 +9301,7 @@ and __ocaml_lex_lex_json_rec buf lexbuf __ocaml_lex_state =
| 15 ->
# 178 "ext/ext_json_parse.mll"
- (* 6 *) (Eof )
+ (* 30 *) (Eof )
# 408 "ext/ext_json_parse.ml"
| 16 ->
@@ -9221,12 +9340,12 @@ and __ocaml_lex_comment_rec buf lexbuf __ocaml_lex_state =
__ocaml_lex_comment_rec buf lexbuf __ocaml_lex_state
and scan_string buf start lexbuf =
- (* 8 *) __ocaml_lex_scan_string_rec buf start lexbuf 45
+ (* 92 *) __ocaml_lex_scan_string_rec buf start lexbuf 45
and __ocaml_lex_scan_string_rec buf start lexbuf __ocaml_lex_state =
- (* 8 *) match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with
+ (* 92 *) match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with
| 0 ->
# 187 "ext/ext_json_parse.mll"
- (* 4 *) ( () )
+ (* 44 *) ( () )
# 452 "ext/ext_json_parse.ml"
| 1 ->
@@ -9249,7 +9368,7 @@ and __ocaml_lex_scan_string_rec buf start lexbuf __ocaml_lex_state =
# 471 "ext/ext_json_parse.ml"
| 3 ->
-(* 0 *) let
+(* 4 *) let
# 201 "ext/ext_json_parse.mll"
c
# 477 "ext/ext_json_parse.ml"
@@ -9340,7 +9459,7 @@ and
| 8 ->
# 237 "ext/ext_json_parse.mll"
- (* 4 *) (
+ (* 44 *) (
let ofs = lexbuf.lex_start_pos in
let len = lexbuf.lex_curr_pos - ofs in
Buffer.add_substring buf lexbuf.lex_buffer ofs len;
@@ -9370,26 +9489,26 @@ and
let rec parse_json lexbuf =
- (* 11 *) let buf = Buffer.create 64 in
+ (* 35 *) let buf = Buffer.create 64 in
let look_ahead = ref None in
let token () : token =
- (* 63 *) match !look_ahead with
+ (* 359 *) match !look_ahead with
| None ->
- (* 55 *) lex_json buf lexbuf
+ (* 303 *) lex_json buf lexbuf
| Some x ->
- (* 8 *) look_ahead := None ;
+ (* 56 *) look_ahead := None ;
x
in
- let push e = (* 8 *) look_ahead := Some e in
+ let push e = (* 56 *) look_ahead := Some e in
let rec json (lexbuf : Lexing.lexbuf) : Ext_json_types.t =
- (* 23 *) match token () with
- | True -> (* 0 *) True lexbuf.lex_start_p
- | False -> (* 0 *) False lexbuf.lex_start_p
+ (* 119 *) match token () with
+ | True -> (* 4 *) True lexbuf.lex_start_p
+ | False -> (* 4 *) False lexbuf.lex_start_p
| Null -> (* 0 *) Null lexbuf.lex_start_p
- | Number s -> (* 10 *) Flo {flo = s; loc = lexbuf.lex_start_p}
- | String s -> (* 0 *) Str { str = s; loc = lexbuf.lex_start_p}
- | Lbracket -> (* 5 *) parse_array lexbuf.lex_start_p lexbuf.lex_curr_p [] lexbuf
- | Lbrace -> (* 6 *) parse_map lexbuf.lex_start_p String_map.empty lexbuf
+ | Number s -> (* 54 *) Flo {flo = s; loc = lexbuf.lex_start_p}
+ | String s -> (* 16 *) Str { str = s; loc = lexbuf.lex_start_p}
+ | Lbracket -> (* 21 *) parse_array lexbuf.lex_start_p lexbuf.lex_curr_p [] lexbuf
+ | Lbrace -> (* 18 *) parse_map lexbuf.lex_start_p String_map.empty lexbuf
| _ -> (* 2 *) error lexbuf Unexpected_token
(** Note if we remove [trailing_comma] support
we should report errors (actually more work), for example
@@ -9411,35 +9530,35 @@ let rec parse_json lexbuf =
*)
and parse_array loc_start loc_finish acc lexbuf
: Ext_json_types.t =
- (* 10 *) match token () with
+ (* 62 *) match token () with
| Rbracket ->
- (* 2 *) Arr {loc_start ; content = Ext_array.reverse_of_list acc ;
+ (* 6 *) Arr {loc_start ; content = Ext_array.reverse_of_list acc ;
loc_end = lexbuf.lex_curr_p }
| x ->
- (* 8 *) push x ;
+ (* 56 *) push x ;
let new_one = json lexbuf in
begin match token () with
| Comma ->
- (* 5 *) parse_array loc_start loc_finish (new_one :: acc) lexbuf
+ (* 41 *) parse_array loc_start loc_finish (new_one :: acc) lexbuf
| Rbracket
- -> (* 1 *) Arr {content = (Ext_array.reverse_of_list (new_one::acc));
+ -> (* 13 *) Arr {content = (Ext_array.reverse_of_list (new_one::acc));
loc_start ;
loc_end = lexbuf.lex_curr_p }
| _ ->
(* 0 *) error lexbuf Expect_comma_or_rbracket
end
and parse_map loc_start acc lexbuf : Ext_json_types.t =
- (* 10 *) match token () with
+ (* 38 *) match token () with
| Rbrace ->
- (* 3 *) Obj { map = acc ; loc = loc_start}
+ (* 7 *) Obj { map = acc ; loc = loc_start}
| String key ->
- (* 4 *) begin match token () with
+ (* 28 *) begin match token () with
| Colon ->
- (* 4 *) let value = json lexbuf in
+ (* 28 *) let value = json lexbuf in
begin match token () with
- | Rbrace -> (* 0 *) Obj {map = String_map.add key value acc ; loc = loc_start}
+ | Rbrace -> (* 8 *) Obj {map = String_map.add key value acc ; loc = loc_start}
| Comma ->
- (* 4 *) parse_map loc_start (String_map.add key value acc) lexbuf
+ (* 20 *) parse_map loc_start (String_map.add key value acc) lexbuf
| _ -> (* 0 *) error lexbuf Expect_comma_or_rbrace
end
| _ -> (* 0 *) error lexbuf Expect_colon
@@ -9448,11 +9567,11 @@ let rec parse_json lexbuf =
in
let v = json lexbuf in
match token () with
- | Eof -> (* 6 *) v
+ | Eof -> (* 30 *) v
| _ -> (* 0 *) error lexbuf Expect_eof
let parse_json_from_string s =
- (* 11 *) parse_json (Lexing.from_string s )
+ (* 35 *) parse_json (Lexing.from_string s )
let parse_json_from_chan in_chan =
(* 0 *) let lexbuf = Lexing.from_channel in_chan in
@@ -9472,83 +9591,127 @@ let parse_json_from_file s =
# 694 "ext/ext_json_parse.ml"
end
-module Ounit_json_tests
-= struct
-#1 "ounit_json_tests.ml"
+module Ext_json_write : sig
+#1 "ext_json_write.mli"
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-let ((>::),
- (>:::)) = OUnit.((>::),(>:::))
-open Ext_json_parse
-let (|?) m (key, cb) =
- (* 2 *) m |> Ext_json.test key cb
+val to_string : Ext_json_types.t -> string
-exception Parse_error
-let suites =
- __FILE__
- >:::
- [
- "empty_json" >:: begin fun _ ->
- (* 1 *) let v =parse_json_from_string "{}" in
- match v with
- | Obj {map = v} -> (* 1 *) OUnit.assert_equal (String_map.is_empty v ) true
- | _ -> (* 0 *) OUnit.assert_failure "should be empty"
- end
- ;
- "empty_arr" >:: begin fun _ ->
- (* 1 *) let v =parse_json_from_string "[]" in
- match v with
- | Arr {content = [||]} -> (* 1 *) ()
- | _ -> (* 0 *) OUnit.assert_failure "should be empty"
- end
- ;
- "empty trails" >:: begin fun _ ->
- (* 1 *) (OUnit.assert_raises Parse_error @@ fun _ ->
- (* 1 *) try parse_json_from_string {| [,]|} with _ -> (* 1 *) raise Parse_error);
- OUnit.assert_raises Parse_error @@ fun _ ->
- (* 1 *) try parse_json_from_string {| {,}|} with _ -> (* 1 *) raise Parse_error
- end;
- "two trails" >:: begin fun _ ->
- (* 1 *) (OUnit.assert_raises Parse_error @@ fun _ ->
- (* 1 *) try parse_json_from_string {| [1,2,,]|} with _ -> (* 1 *) raise Parse_error);
- (OUnit.assert_raises Parse_error @@ fun _ ->
- (* 1 *) try parse_json_from_string {| { "x": 3, ,}|} with _ -> (* 1 *) raise Parse_error)
- end;
- "two trails fail" >:: begin fun _ ->
- (* 1 *) (OUnit.assert_raises Parse_error @@ fun _ ->
- (* 1 *) try parse_json_from_string {| { "x": 3, 2 ,}|} with _ -> (* 1 *) raise Parse_error)
- end;
+val to_channel : out_channel -> Ext_json_types.t -> unit
+end = struct
+#1 "ext_json_write.ml"
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
- "trail comma obj" >:: begin fun _ ->
- (* 1 *) let v = parse_json_from_string {| { "x" : 3 , }|} in
- let v1 = parse_json_from_string {| { "x" : 3 , }|} in
- let test (v : Ext_json_types.t) =
- (* 2 *) match v with
- | Obj {map = v} ->
- (* 2 *) v
- |? ("x" , `Flo (fun x -> (* 2 *) OUnit.assert_equal x "3"))
- |> ignore
- | _ -> (* 0 *) OUnit.assert_failure "trail comma" in
- test v ;
- test v1
- end
- ;
- "trail comma arr" >:: begin fun _ ->
- (* 1 *) let v = parse_json_from_string {| [ 1, 3, ]|} in
- let v1 = parse_json_from_string {| [ 1, 3 ]|} in
- let test (v : Ext_json_types.t) =
- (* 2 *) match v with
- | Arr { content = [| Flo {flo = "1"} ; Flo { flo = "3"} |] } -> (* 2 *) ()
- | _ -> (* 0 *) OUnit.assert_failure "trailing comma array" in
- test v ;
- test v1
+(** poor man's serialization *)
+
+let quot x =
+ (* 30 *) "\"" ^ String.escaped x ^ "\""
+
+let rec encode_aux (x : Ext_json_types.t )
+ (buf : Buffer.t) : unit =
+ (* 72 *) let a str = (* 162 *) Buffer.add_string buf str in
+ match x with
+ | Null _ -> (* 0 *) a "null"
+ | Str {str = s } -> (* 12 *) a (quot s)
+ | Flo {flo = s} -> (* 33 *) a s
+ | Arr {content} ->
+ (* 12 *) begin match content with
+ | [||] -> (* 3 *) a "[]"
+ | _ ->
+ (* 9 *) a "[ ";
+ encode_aux
+ (Array.unsafe_get content 0)
+ buf ;
+ for i = 1 to Array.length content - 1 do
+ (* 27 *) a " , ";
+ encode_aux
+ (Array.unsafe_get content i)
+ buf
+ done;
+ a " ]"
end
- ]
+ | True _ -> (* 3 *) a "true"
+ | False _ -> (* 3 *) a "false"
+ | Obj {map} ->
+ (* 9 *) if String_map.is_empty map then
+ (* 3 *) a "{}"
+ else
+ (* 6 *) begin
+ (*prerr_endline "WEIRD";
+ prerr_endline (string_of_int @@ String_map.cardinal map ); *)
+ a "{ ";
+ let _ : int = String_map.fold (fun k v i ->
+ (* 18 *) if i <> 0 then (* 12 *) begin
+ a " , "
+ end;
+ a (quot k);
+ a " : ";
+ encode_aux v buf ;
+ i + 1
+ ) map 0 in
+ a " }"
+ end
+
+
+let to_string (x : Ext_json_types.t) =
+ (* 18 *) let buf = Buffer.create 1024 in
+ encode_aux x buf ;
+ Buffer.contents buf
+
+let to_channel (oc : out_channel) x =
+ (* 0 *) let buf = Buffer.create 1024 in
+ encode_aux x buf ;
+ Buffer.output_buffer oc buf
end
-module Ext_list : sig
-#1 "ext_list.mli"
+module Ext_pervasives : sig
+#1 "ext_pervasives.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -9580,50 +9743,408 @@ module Ext_list : sig
-(** Extension to the standard library [List] module *)
-
-(** TODO some function are no efficiently implemented. *)
+(** Extension to standard library [Pervavives] module, safe to open
+ *)
-val filter_map : ('a -> 'b option) -> 'a list -> 'b list
+external reraise: exn -> 'a = "%reraise"
-val excludes : ('a -> bool) -> 'a list -> bool * 'a list
-val exclude_with_fact : ('a -> bool) -> 'a list -> 'a option * 'a list
-val exclude_with_fact2 :
- ('a -> bool) -> ('a -> bool) -> 'a list -> 'a option * 'a option * 'a list
-val same_length : 'a list -> 'b list -> bool
+val finally : 'a -> ('a -> 'c) -> ('a -> 'b) -> 'b
-val init : int -> (int -> 'a) -> 'a list
+val with_file_as_chan : string -> (out_channel -> 'a) -> 'a
-val take : int -> 'a list -> 'a list * 'a list
-val try_take : int -> 'a list -> 'a list * int * 'a list
+val with_file_as_pp : string -> (Format.formatter -> 'a) -> 'a
-val exclude_tail : 'a list -> 'a * 'a list
+val is_pos_pow : Int32.t -> int
-val length_compare : 'a list -> int -> [`Gt | `Eq | `Lt ]
+val failwithf : loc:string -> ('a, unit, string, 'b) format4 -> 'a
-(**
+val invalid_argf : ('a, unit, string, 'b) format4 -> 'a
- {[length xs = length ys + n ]}
- input n should be positive
- TODO: input checking
-*)
+val bad_argf : ('a, unit, string, 'b) format4 -> 'a
-val length_larger_than_n :
- int -> 'a list -> 'a list -> bool
-val filter_map2 : ('a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list
-val filter_map2i : (int -> 'a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list
+val dump : 'a -> string
+val pp_any : Format.formatter -> 'a -> unit
+external id : 'a -> 'a = "%identity"
-val filter_mapi : (int -> 'a -> 'b option) -> 'a list -> 'b list
+(** Copied from {!Btype.hash_variant}:
+ need sync up and add test case
+ *)
+val hash_variant : string -> int
-val flat_map2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list
+end = struct
+#1 "ext_pervasives.ml"
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-val flat_map_acc : ('a -> 'b list) -> 'b list -> 'a list -> 'b list
-val flat_map : ('a -> 'b list) -> 'a list -> 'b list
-(** for the last element the first element will be passed [true] *)
+
+
+
+external reraise: exn -> 'a = "%reraise"
+
+let finally v action f =
+ (* 0 *) match f v with
+ | exception e ->
+ (* 0 *) action v ;
+ reraise e
+ | e -> (* 0 *) action v ; e
+
+let with_file_as_chan filename f =
+ (* 0 *) finally (open_out_bin filename) close_out f
+
+let with_file_as_pp filename f =
+ (* 0 *) finally (open_out_bin filename) close_out
+ (fun chan ->
+ (* 0 *) let fmt = Format.formatter_of_out_channel chan in
+ let v = f fmt in
+ Format.pp_print_flush fmt ();
+ v
+ )
+
+
+let is_pos_pow n =
+ (* 0 *) let module M = struct exception E end in
+ let rec aux c (n : Int32.t) =
+ (* 0 *) if n <= 0l then (* 0 *) -2
+ else (* 0 *) if n = 1l then (* 0 *) c
+ else (* 0 *) if Int32.logand n 1l = 0l then
+ (* 0 *) aux (c + 1) (Int32.shift_right n 1 )
+ else (* 0 *) raise M.E in
+ try aux 0 n with M.E -> (* 0 *) -1
+
+let failwithf ~loc fmt = (* 0 *) Format.ksprintf (fun s -> (* 0 *) failwith (loc ^ s))
+ fmt
+
+let invalid_argf fmt = (* 0 *) Format.ksprintf invalid_arg fmt
+
+let bad_argf fmt = (* 0 *) Format.ksprintf (fun x -> (* 0 *) raise (Arg.Bad x ) ) fmt
+
+
+let rec dump r =
+ (* 0 *) if Obj.is_int r then
+ (* 0 *) string_of_int (Obj.magic r : int)
+ else (* Block. *)
+ (* 0 *) let rec get_fields acc = function
+ | 0 -> (* 0 *) acc
+ | n -> (* 0 *) let n = n-1 in get_fields (Obj.field r n :: acc) n
+ in
+ let rec is_list r =
+ (* 0 *) if Obj.is_int r then
+ (* 0 *) r = Obj.repr 0 (* [] *)
+ else
+ (* 0 *) let s = Obj.size r and t = Obj.tag r in
+ t = 0 && s = 2 && is_list (Obj.field r 1) (* h :: t *)
+ in
+ let rec get_list r =
+ (* 0 *) if Obj.is_int r then
+ (* 0 *) []
+ else
+ (* 0 *) let h = Obj.field r 0 and t = get_list (Obj.field r 1) in
+ h :: t
+ in
+ let opaque name =
+ (* XXX In future, print the address of value 'r'. Not possible
+ * in pure OCaml at the moment. *)
+ (* 0 *) "<" ^ name ^ ">"
+ in
+ let s = Obj.size r and t = Obj.tag r in
+ (* From the tag, determine the type of block. *)
+ match t with
+ | _ when (* 0 *) is_list r ->
+ (* 0 *) let fields = get_list r in
+ "[" ^ String.concat "; " (List.map dump fields) ^ "]"
+ | 0 ->
+ (* 0 *) let fields = get_fields [] s in
+ "(" ^ String.concat ", " (List.map dump fields) ^ ")"
+ | x when (* 0 *) x = Obj.lazy_tag ->
+ (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not
+ * clear if very large constructed values could have the same
+ * tag. XXX *)
+ (* 0 *) opaque "lazy"
+ | x when (* 0 *) x = Obj.closure_tag ->
+ (* 0 *) opaque "closure"
+ | x when (* 0 *) x = Obj.object_tag ->
+ (* 0 *) let fields = get_fields [] s in
+ let _clasz, id, slots =
+ match fields with
+ | h::h'::t -> (* 0 *) h, h', t
+ | _ -> (* 0 *) assert false
+ in
+ (* No information on decoding the class (first field). So just print
+ * out the ID and the slots. *)
+ "Object #" ^ dump id ^ " (" ^ String.concat ", " (List.map dump slots) ^ ")"
+ | x when (* 0 *) x = Obj.infix_tag ->
+ (* 0 *) opaque "infix"
+ | x when (* 0 *) x = Obj.forward_tag ->
+ (* 0 *) opaque "forward"
+ | x when (* 0 *) x < Obj.no_scan_tag ->
+ (* 0 *) let fields = get_fields [] s in
+ "Tag" ^ string_of_int t ^
+ " (" ^ String.concat ", " (List.map dump fields) ^ ")"
+ | x when (* 0 *) x = Obj.string_tag ->
+ (* 0 *) "\"" ^ String.escaped (Obj.magic r : string) ^ "\""
+ | x when (* 0 *) x = Obj.double_tag ->
+ (* 0 *) string_of_float (Obj.magic r : float)
+ | x when (* 0 *) x = Obj.abstract_tag ->
+ (* 0 *) opaque "abstract"
+ | x when (* 0 *) x = Obj.custom_tag ->
+ (* 0 *) opaque "custom"
+ | x when (* 0 *) x = Obj.custom_tag ->
+ (* 0 *) opaque "final"
+ | x when (* 0 *) x = Obj.double_array_tag ->
+ (* 0 *) "[|"^
+ String.concat ";"
+ (Array.to_list (Array.map string_of_float (Obj.magic r : float array))) ^
+ "|]"
+ | _ ->
+ (* 0 *) opaque (Printf.sprintf "unknown: tag %d size %d" t s)
+
+let dump v = (* 0 *) dump (Obj.repr v)
+
+let pp_any fmt v =
+ (* 0 *) Format.fprintf fmt "@[%s@]"
+ (dump v )
+external id : 'a -> 'a = "%identity"
+
+
+let hash_variant s =
+ (* 0 *) let accu = ref 0 in
+ for i = 0 to String.length s - 1 do
+ (* 0 *) accu := 223 * !accu + Char.code s.[i]
+ done;
+ (* reduce to 31 bits *)
+ accu := !accu land (1 lsl 31 - 1);
+ (* make it signed for 64 bits architectures *)
+ if !accu > 0x3FFFFFFF then (* 0 *) !accu - (1 lsl 31) else (* 0 *) !accu
+
+
+end
+module Ounit_json_tests
+= struct
+#1 "ounit_json_tests.ml"
+
+let ((>::),
+ (>:::)) = OUnit.((>::),(>:::))
+
+open Ext_json_parse
+let (|?) m (key, cb) =
+ (* 2 *) m |> Ext_json.test key cb
+
+let id_parsing_serializing x =
+ (* 6 *) let normal_s =
+ Ext_json_write.to_string ( Ext_json_parse.parse_json_from_string x )
+ in
+ let normal_ss =
+ Ext_json_write.to_string
+ (Ext_json_parse.parse_json_from_string normal_s)
+ in
+ if normal_s <> normal_ss then
+ (* 0 *) begin
+ prerr_endline "ERROR";
+ prerr_endline normal_s ;
+ prerr_endline normal_ss ;
+ end;
+ OUnit.assert_equal ~cmp:(fun (x:string) y -> (* 6 *) x = y) normal_s normal_ss
+
+let id_parsing_x2 x =
+ (* 6 *) let stru = Ext_json_parse.parse_json_from_string x in
+ let normal_s = Ext_json_write.to_string stru in
+ let normal_ss = (Ext_json_parse.parse_json_from_string normal_s) in
+ if Ext_json.equal stru normal_ss then
+ (* 6 *) true
+ else (* 0 *) begin
+ prerr_endline "ERROR";
+ prerr_endline normal_s;
+ Format.fprintf Format.err_formatter
+ "%a@.%a@." Ext_pervasives.pp_any stru Ext_pervasives.pp_any normal_ss;
+
+ prerr_endline (Ext_json_write.to_string normal_ss);
+ false
+ end
+
+let test_data =
+ [{|
+ {}
+ |};
+ {| [] |};
+ {| [1,2,3]|};
+ {| ["x", "y", 1,2,3 ]|};
+ {| { "x" : 3, "y" : "x", "z" : [1,2,3, "x"] }|};
+ {| {"x " : true , "y" : false , "z\"" : 1} |}
+ ]
+exception Parse_error
+let suites =
+ __FILE__
+ >:::
+ [
+
+ __LOC__ >:: begin fun _ ->
+ (* 1 *) List.iter id_parsing_serializing test_data
+ end;
+
+ __LOC__ >:: begin fun _ ->
+ (* 1 *) List.iteri (fun i x -> (* 6 *) OUnit.assert_bool (__LOC__ ^ string_of_int i ) (id_parsing_x2 x)) test_data
+ end;
+ "empty_json" >:: begin fun _ ->
+ (* 1 *) let v =parse_json_from_string "{}" in
+ match v with
+ | Obj {map = v} -> (* 1 *) OUnit.assert_equal (String_map.is_empty v ) true
+ | _ -> (* 0 *) OUnit.assert_failure "should be empty"
+ end
+ ;
+ "empty_arr" >:: begin fun _ ->
+ (* 1 *) let v =parse_json_from_string "[]" in
+ match v with
+ | Arr {content = [||]} -> (* 1 *) ()
+ | _ -> (* 0 *) OUnit.assert_failure "should be empty"
+ end
+ ;
+ "empty trails" >:: begin fun _ ->
+ (* 1 *) (OUnit.assert_raises Parse_error @@ fun _ ->
+ (* 1 *) try parse_json_from_string {| [,]|} with _ -> (* 1 *) raise Parse_error);
+ OUnit.assert_raises Parse_error @@ fun _ ->
+ (* 1 *) try parse_json_from_string {| {,}|} with _ -> (* 1 *) raise Parse_error
+ end;
+ "two trails" >:: begin fun _ ->
+ (* 1 *) (OUnit.assert_raises Parse_error @@ fun _ ->
+ (* 1 *) try parse_json_from_string {| [1,2,,]|} with _ -> (* 1 *) raise Parse_error);
+ (OUnit.assert_raises Parse_error @@ fun _ ->
+ (* 1 *) try parse_json_from_string {| { "x": 3, ,}|} with _ -> (* 1 *) raise Parse_error)
+ end;
+
+ "two trails fail" >:: begin fun _ ->
+ (* 1 *) (OUnit.assert_raises Parse_error @@ fun _ ->
+ (* 1 *) try parse_json_from_string {| { "x": 3, 2 ,}|} with _ -> (* 1 *) raise Parse_error)
+ end;
+
+ "trail comma obj" >:: begin fun _ ->
+ (* 1 *) let v = parse_json_from_string {| { "x" : 3 , }|} in
+ let v1 = parse_json_from_string {| { "x" : 3 , }|} in
+ let test (v : Ext_json_types.t) =
+ (* 2 *) match v with
+ | Obj {map = v} ->
+ (* 2 *) v
+ |? ("x" , `Flo (fun x -> (* 2 *) OUnit.assert_equal x "3"))
+ |> ignore
+ | _ -> (* 0 *) OUnit.assert_failure "trail comma" in
+ test v ;
+ test v1
+ end
+ ;
+ "trail comma arr" >:: begin fun _ ->
+ (* 1 *) let v = parse_json_from_string {| [ 1, 3, ]|} in
+ let v1 = parse_json_from_string {| [ 1, 3 ]|} in
+ let test (v : Ext_json_types.t) =
+ (* 2 *) match v with
+ | Arr { content = [| Flo {flo = "1"} ; Flo { flo = "3"} |] } -> (* 2 *) ()
+ | _ -> (* 0 *) OUnit.assert_failure "trailing comma array" in
+ test v ;
+ test v1
+ end
+ ]
+
+end
+module Ext_list : sig
+#1 "ext_list.mli"
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+
+
+
+
+
+
+
+
+(** Extension to the standard library [List] module *)
+
+(** TODO some function are no efficiently implemented. *)
+
+val filter_map : ('a -> 'b option) -> 'a list -> 'b list
+
+val excludes : ('a -> bool) -> 'a list -> bool * 'a list
+val exclude_with_fact : ('a -> bool) -> 'a list -> 'a option * 'a list
+val exclude_with_fact2 :
+ ('a -> bool) -> ('a -> bool) -> 'a list -> 'a option * 'a option * 'a list
+val same_length : 'a list -> 'b list -> bool
+
+val init : int -> (int -> 'a) -> 'a list
+
+val take : int -> 'a list -> 'a list * 'a list
+val try_take : int -> 'a list -> 'a list * int * 'a list
+
+val exclude_tail : 'a list -> 'a * 'a list
+
+val length_compare : 'a list -> int -> [`Gt | `Eq | `Lt ]
+
+(**
+
+ {[length xs = length ys + n ]}
+ input n should be positive
+ TODO: input checking
+*)
+
+val length_larger_than_n :
+ int -> 'a list -> 'a list -> bool
+
+val filter_map2 : ('a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list
+
+val filter_map2i : (int -> 'a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list
+
+val filter_mapi : (int -> 'a -> 'b option) -> 'a list -> 'b list
+
+val flat_map2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list
+
+val flat_map_acc : ('a -> 'b list) -> 'b list -> 'a list -> 'b list
+val flat_map : ('a -> 'b list) -> 'a list -> 'b list
+
+
+(** for the last element the first element will be passed [true] *)
val fold_right2_last : (bool -> 'a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
@@ -10560,239 +11081,6 @@ let suites =
end
]
-end
-module Ext_pervasives : sig
-#1 "ext_pervasives.mli"
-(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
- *
- * This program is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published by
- * the Free Software Foundation, either version 3 of the License, or
- * (at your option) any later version.
- *
- * In addition to the permissions granted to you by the LGPL, you may combine
- * or link a "work that uses the Library" with a publicly distributed version
- * of this file to produce a combined library or application, then distribute
- * that combined work under the terms of your choosing, with no requirement
- * to comply with the obligations normally placed on you by section 4 of the
- * LGPL version 3 (or the corresponding section of a later version of the LGPL
- * should you choose to use a later version).
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public License
- * along with this program; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-
-
-
-
-
-
-
-
-(** Extension to standard library [Pervavives] module, safe to open
- *)
-
-external reraise: exn -> 'a = "%reraise"
-
-val finally : 'a -> ('a -> 'c) -> ('a -> 'b) -> 'b
-
-val with_file_as_chan : string -> (out_channel -> 'a) -> 'a
-
-val with_file_as_pp : string -> (Format.formatter -> 'a) -> 'a
-
-val is_pos_pow : Int32.t -> int
-
-val failwithf : loc:string -> ('a, unit, string, 'b) format4 -> 'a
-
-val invalid_argf : ('a, unit, string, 'b) format4 -> 'a
-
-val bad_argf : ('a, unit, string, 'b) format4 -> 'a
-
-
-
-val dump : 'a -> string
-val pp_any : Format.formatter -> 'a -> unit
-external id : 'a -> 'a = "%identity"
-
-(** Copied from {!Btype.hash_variant}:
- need sync up and add test case
- *)
-val hash_variant : string -> int
-
-end = struct
-#1 "ext_pervasives.ml"
-(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
- *
- * This program is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published by
- * the Free Software Foundation, either version 3 of the License, or
- * (at your option) any later version.
- *
- * In addition to the permissions granted to you by the LGPL, you may combine
- * or link a "work that uses the Library" with a publicly distributed version
- * of this file to produce a combined library or application, then distribute
- * that combined work under the terms of your choosing, with no requirement
- * to comply with the obligations normally placed on you by section 4 of the
- * LGPL version 3 (or the corresponding section of a later version of the LGPL
- * should you choose to use a later version).
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public License
- * along with this program; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-
-
-
-
-
-
-external reraise: exn -> 'a = "%reraise"
-
-let finally v action f =
- (* 0 *) match f v with
- | exception e ->
- (* 0 *) action v ;
- reraise e
- | e -> (* 0 *) action v ; e
-
-let with_file_as_chan filename f =
- (* 0 *) finally (open_out_bin filename) close_out f
-
-let with_file_as_pp filename f =
- (* 0 *) finally (open_out_bin filename) close_out
- (fun chan ->
- (* 0 *) let fmt = Format.formatter_of_out_channel chan in
- let v = f fmt in
- Format.pp_print_flush fmt ();
- v
- )
-
-
-let is_pos_pow n =
- (* 0 *) let module M = struct exception E end in
- let rec aux c (n : Int32.t) =
- (* 0 *) if n <= 0l then (* 0 *) -2
- else (* 0 *) if n = 1l then (* 0 *) c
- else (* 0 *) if Int32.logand n 1l = 0l then
- (* 0 *) aux (c + 1) (Int32.shift_right n 1 )
- else (* 0 *) raise M.E in
- try aux 0 n with M.E -> (* 0 *) -1
-
-let failwithf ~loc fmt = (* 0 *) Format.ksprintf (fun s -> (* 0 *) failwith (loc ^ s))
- fmt
-
-let invalid_argf fmt = (* 0 *) Format.ksprintf invalid_arg fmt
-
-let bad_argf fmt = (* 0 *) Format.ksprintf (fun x -> (* 0 *) raise (Arg.Bad x ) ) fmt
-
-
-let rec dump r =
- (* 0 *) if Obj.is_int r then
- (* 0 *) string_of_int (Obj.magic r : int)
- else (* Block. *)
- (* 0 *) let rec get_fields acc = function
- | 0 -> (* 0 *) acc
- | n -> (* 0 *) let n = n-1 in get_fields (Obj.field r n :: acc) n
- in
- let rec is_list r =
- (* 0 *) if Obj.is_int r then
- (* 0 *) r = Obj.repr 0 (* [] *)
- else
- (* 0 *) let s = Obj.size r and t = Obj.tag r in
- t = 0 && s = 2 && is_list (Obj.field r 1) (* h :: t *)
- in
- let rec get_list r =
- (* 0 *) if Obj.is_int r then
- (* 0 *) []
- else
- (* 0 *) let h = Obj.field r 0 and t = get_list (Obj.field r 1) in
- h :: t
- in
- let opaque name =
- (* XXX In future, print the address of value 'r'. Not possible
- * in pure OCaml at the moment. *)
- (* 0 *) "<" ^ name ^ ">"
- in
- let s = Obj.size r and t = Obj.tag r in
- (* From the tag, determine the type of block. *)
- match t with
- | _ when (* 0 *) is_list r ->
- (* 0 *) let fields = get_list r in
- "[" ^ String.concat "; " (List.map dump fields) ^ "]"
- | 0 ->
- (* 0 *) let fields = get_fields [] s in
- "(" ^ String.concat ", " (List.map dump fields) ^ ")"
- | x when (* 0 *) x = Obj.lazy_tag ->
- (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not
- * clear if very large constructed values could have the same
- * tag. XXX *)
- (* 0 *) opaque "lazy"
- | x when (* 0 *) x = Obj.closure_tag ->
- (* 0 *) opaque "closure"
- | x when (* 0 *) x = Obj.object_tag ->
- (* 0 *) let fields = get_fields [] s in
- let _clasz, id, slots =
- match fields with
- | h::h'::t -> (* 0 *) h, h', t
- | _ -> (* 0 *) assert false
- in
- (* No information on decoding the class (first field). So just print
- * out the ID and the slots. *)
- "Object #" ^ dump id ^ " (" ^ String.concat ", " (List.map dump slots) ^ ")"
- | x when (* 0 *) x = Obj.infix_tag ->
- (* 0 *) opaque "infix"
- | x when (* 0 *) x = Obj.forward_tag ->
- (* 0 *) opaque "forward"
- | x when (* 0 *) x < Obj.no_scan_tag ->
- (* 0 *) let fields = get_fields [] s in
- "Tag" ^ string_of_int t ^
- " (" ^ String.concat ", " (List.map dump fields) ^ ")"
- | x when (* 0 *) x = Obj.string_tag ->
- (* 0 *) "\"" ^ String.escaped (Obj.magic r : string) ^ "\""
- | x when (* 0 *) x = Obj.double_tag ->
- (* 0 *) string_of_float (Obj.magic r : float)
- | x when (* 0 *) x = Obj.abstract_tag ->
- (* 0 *) opaque "abstract"
- | x when (* 0 *) x = Obj.custom_tag ->
- (* 0 *) opaque "custom"
- | x when (* 0 *) x = Obj.custom_tag ->
- (* 0 *) opaque "final"
- | x when (* 0 *) x = Obj.double_array_tag ->
- (* 0 *) "[|"^
- String.concat ";"
- (Array.to_list (Array.map string_of_float (Obj.magic r : float array))) ^
- "|]"
- | _ ->
- (* 0 *) opaque (Printf.sprintf "unknown: tag %d size %d" t s)
-
-let dump v = (* 0 *) dump (Obj.repr v)
-
-let pp_any fmt v =
- (* 0 *) Format.fprintf fmt "@[%s@]"
- (dump v )
-external id : 'a -> 'a = "%identity"
-
-
-let hash_variant s =
- (* 0 *) let accu = ref 0 in
- for i = 0 to String.length s - 1 do
- (* 0 *) accu := 223 * !accu + Char.code s.[i]
- done;
- (* reduce to 31 bits *)
- accu := !accu land (1 lsl 31 - 1);
- (* make it signed for 64 bits architectures *)
- if !accu > 0x3FFFFFFF then (* 0 *) !accu - (1 lsl 31) else (* 0 *) !accu
-
-
end
module Ext_filename : sig
#1 "ext_filename.mli"
@@ -13197,8 +13485,8 @@ let suites =
__LOC__ >:: begin fun _ ->
(* 1 *) OUnit.assert_bool __LOC__ @@
- List.for_all (fun x -> (* 10 *) Ext_string.is_valid_source_name x = Good)
- ["x.ml"; "x.mli"; "x.re"; "x.rei"; "x.mll";
+ List.for_all (fun x -> (* 9 *) Ext_string.is_valid_source_name x = Good)
+ ["x.ml"; "x.mli"; "x.re"; "x.rei";
"A_x.ml"; "ab.ml"; "a_.ml"; "a__.ml";
"ax.ml"];
OUnit.assert_bool __LOC__ @@ not @@
diff --git a/jscomp/bin/all_ounit_tests.ml b/jscomp/bin/all_ounit_tests.ml
index a6c9297f24..9f1088b5e6 100644
--- a/jscomp/bin/all_ounit_tests.ml
+++ b/jscomp/bin/all_ounit_tests.ml
@@ -1320,6 +1320,12 @@ val find_and_split :
val exists : ('a -> bool) -> 'a array -> bool
val is_empty : 'a array -> bool
+
+val for_all2_no_exn :
+ ('a -> 'b -> bool) ->
+ 'a array ->
+ 'b array ->
+ bool
end = struct
#1 "ext_array.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
@@ -1508,6 +1514,21 @@ let exists p a =
let is_empty arr =
Array.length arr = 0
+
+
+let rec unsafe_loop index len p xs ys =
+ if index >= len then true
+ else
+ p
+ (Array.unsafe_get xs index)
+ (Array.unsafe_get ys index) &&
+ unsafe_loop (succ index) len p xs ys
+
+let for_all2_no_exn p xs ys =
+ let len_xs = Array.length xs in
+ let len_ys = Array.length ys in
+ len_xs = len_ys &&
+ unsafe_loop 0 len_xs p xs ys
end
module Ext_bytes : sig
#1 "ext_bytes.mli"
@@ -2143,7 +2164,8 @@ let is_valid_source_name name : check_result =
match check_any_suffix_case_then_chop name [
".ml";
".re";
- ".mli"; ".mll"; ".rei"
+ ".mli";
+ ".rei"
] with
| None -> Suffix_mismatch
| Some x ->
@@ -2342,6 +2364,34 @@ let suites =
[|1;2;3;4;5;6|] []
=~ [2;4;6]
end;
+
+ __LOC__ >:: begin fun _ ->
+ OUnit.assert_bool __LOC__
+ (Ext_array.for_all2_no_exn
+ (=)
+ [|1;2;3|]
+ [|1;2;3|]
+ )
+ end;
+ __LOC__ >:: begin fun _ ->
+ OUnit.assert_bool __LOC__
+ (Ext_array.for_all2_no_exn
+ (=) [||] [||]
+ );
+ OUnit.assert_bool __LOC__
+ (not @@ Ext_array.for_all2_no_exn
+ (=) [||] [|1|]
+ )
+ end
+ ;
+ __LOC__ >:: begin fun _ ->
+ OUnit.assert_bool __LOC__
+ (not (Ext_array.for_all2_no_exn
+ (=)
+ [|1;2;3|]
+ [|1;2;33|]
+ ))
+ end
]
end
module Ounit_tests_util
@@ -8661,9 +8711,32 @@ val query : path -> Ext_json_types.t -> status
val loc_of : Ext_json_types.t -> Ext_position.t
+val equal : Ext_json_types.t -> Ext_json_types.t -> bool
end = struct
#1 "ext_json.ml"
-
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
type callback =
[
@@ -8679,7 +8752,7 @@ type callback =
| `Id of (Ext_json_types.t -> unit )
]
-
+
type path = string list
type status =
@@ -8689,26 +8762,26 @@ type status =
let test ?(fail=(fun () -> ())) key
(cb : callback) (m : Ext_json_types.t String_map.t)
- =
- begin match String_map.find_exn key m, cb with
- | exception Not_found ->
- begin match cb with `Not_found f -> f ()
- | _ -> fail ()
- end
- | True _, `Bool cb -> cb true
- | False _, `Bool cb -> cb false
- | Flo {flo = s} , `Flo cb -> cb s
- | Obj {map = b} , `Obj cb -> cb b
- | Arr {content}, `Arr cb -> cb content
- | Arr {content; loc_start ; loc_end}, `Arr_loc cb ->
- cb content loc_start loc_end
- | Null _, `Null cb -> cb ()
- | Str {str = s }, `Str cb -> cb s
- | Str {str = s ; loc }, `Str_loc cb -> cb s loc
- | any , `Id cb -> cb any
- | _, _ -> fail ()
- end;
- m
+ =
+ begin match String_map.find_exn key m, cb with
+ | exception Not_found ->
+ begin match cb with `Not_found f -> f ()
+ | _ -> fail ()
+ end
+ | True _, `Bool cb -> cb true
+ | False _, `Bool cb -> cb false
+ | Flo {flo = s} , `Flo cb -> cb s
+ | Obj {map = b} , `Obj cb -> cb b
+ | Arr {content}, `Arr cb -> cb content
+ | Arr {content; loc_start ; loc_end}, `Arr_loc cb ->
+ cb content loc_start loc_end
+ | Null _, `Null cb -> cb ()
+ | Str {str = s }, `Str cb -> cb s
+ | Str {str = s ; loc }, `Str_loc cb -> cb s loc
+ | any , `Id cb -> cb any
+ | _, _ -> fail ()
+ end;
+ m
let query path (json : Ext_json_types.t ) =
let rec aux acc paths json =
match path with
@@ -8732,7 +8805,53 @@ let loc_of (x : Ext_json_types.t) =
| Arr p -> p.loc_start
| Obj p -> p.loc
| Flo p -> p.loc
-
+
+
+let rec equal
+ (x : Ext_json_types.t)
+ (y : Ext_json_types.t) =
+ match x with
+ | Null _ -> (* [%p? Null _ ] *)
+ begin match y with
+ | Null _ -> true
+ | _ -> false end
+ | Str {str } ->
+ begin match y with
+ | Str {str = str2} -> str = str2
+ | _ -> false end
+ | Flo {flo}
+ ->
+ begin match y with
+ | Flo {flo = flo2} ->
+ flo = flo2
+ | _ -> false
+ end
+ | True _ ->
+ begin match y with
+ | True _ -> true
+ | _ -> false
+ end
+ | False _ ->
+ begin match y with
+ | False _ -> true
+ | _ -> false
+ end
+ | Arr {content}
+ ->
+ begin match y with
+ | Arr {content = content2}
+ ->
+ Ext_array.for_all2_no_exn equal content content2
+ | _ -> false
+ end
+
+ | Obj {map} ->
+ begin match y with
+ | Obj { map = map2} ->
+ String_map.equal equal map map2
+ | _ -> false
+ end
+
end
module Ext_json_parse : sig
@@ -9472,83 +9591,128 @@ let parse_json_from_file s =
# 694 "ext/ext_json_parse.ml"
end
-module Ounit_json_tests
-= struct
-#1 "ounit_json_tests.ml"
+module Ext_json_write : sig
+#1 "ext_json_write.mli"
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-let ((>::),
- (>:::)) = OUnit.((>::),(>:::))
-open Ext_json_parse
-let (|?) m (key, cb) =
- m |> Ext_json.test key cb
+val to_string : Ext_json_types.t -> string
-exception Parse_error
-let suites =
- __FILE__
- >:::
- [
- "empty_json" >:: begin fun _ ->
- let v =parse_json_from_string "{}" in
- match v with
- | Obj {map = v} -> OUnit.assert_equal (String_map.is_empty v ) true
- | _ -> OUnit.assert_failure "should be empty"
- end
- ;
- "empty_arr" >:: begin fun _ ->
- let v =parse_json_from_string "[]" in
- match v with
- | Arr {content = [||]} -> ()
- | _ -> OUnit.assert_failure "should be empty"
- end
- ;
- "empty trails" >:: begin fun _ ->
- (OUnit.assert_raises Parse_error @@ fun _ ->
- try parse_json_from_string {| [,]|} with _ -> raise Parse_error);
- OUnit.assert_raises Parse_error @@ fun _ ->
- try parse_json_from_string {| {,}|} with _ -> raise Parse_error
- end;
- "two trails" >:: begin fun _ ->
- (OUnit.assert_raises Parse_error @@ fun _ ->
- try parse_json_from_string {| [1,2,,]|} with _ -> raise Parse_error);
- (OUnit.assert_raises Parse_error @@ fun _ ->
- try parse_json_from_string {| { "x": 3, ,}|} with _ -> raise Parse_error)
- end;
- "two trails fail" >:: begin fun _ ->
- (OUnit.assert_raises Parse_error @@ fun _ ->
- try parse_json_from_string {| { "x": 3, 2 ,}|} with _ -> raise Parse_error)
- end;
+val to_channel : out_channel -> Ext_json_types.t -> unit
+end = struct
+#1 "ext_json_write.ml"
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
- "trail comma obj" >:: begin fun _ ->
- let v = parse_json_from_string {| { "x" : 3 , }|} in
- let v1 = parse_json_from_string {| { "x" : 3 , }|} in
- let test (v : Ext_json_types.t) =
- match v with
- | Obj {map = v} ->
- v
- |? ("x" , `Flo (fun x -> OUnit.assert_equal x "3"))
- |> ignore
- | _ -> OUnit.assert_failure "trail comma" in
- test v ;
- test v1
- end
- ;
- "trail comma arr" >:: begin fun _ ->
- let v = parse_json_from_string {| [ 1, 3, ]|} in
- let v1 = parse_json_from_string {| [ 1, 3 ]|} in
- let test (v : Ext_json_types.t) =
- match v with
- | Arr { content = [| Flo {flo = "1"} ; Flo { flo = "3"} |] } -> ()
- | _ -> OUnit.assert_failure "trailing comma array" in
- test v ;
- test v1
+(** poor man's serialization *)
+
+let quot x =
+ "\"" ^ String.escaped x ^ "\""
+
+let rec encode_aux (x : Ext_json_types.t )
+ (buf : Buffer.t) : unit =
+ let a str = Buffer.add_string buf str in
+ match x with
+ | Null _ -> a "null"
+ | Str {str = s } -> a (quot s)
+ | Flo {flo = s} ->
+ a s (* since our parsing keep the original float representation, we just dump it as is, there is no cases like [nan] *)
+ | Arr {content} ->
+ begin match content with
+ | [||] -> a "[]"
+ | _ ->
+ a "[ ";
+ encode_aux
+ (Array.unsafe_get content 0)
+ buf ;
+ for i = 1 to Array.length content - 1 do
+ a " , ";
+ encode_aux
+ (Array.unsafe_get content i)
+ buf
+ done;
+ a " ]"
end
- ]
+ | True _ -> a "true"
+ | False _ -> a "false"
+ | Obj {map} ->
+ if String_map.is_empty map then
+ a "{}"
+ else
+ begin
+ (*prerr_endline "WEIRD";
+ prerr_endline (string_of_int @@ String_map.cardinal map ); *)
+ a "{ ";
+ let _ : int = String_map.fold (fun k v i ->
+ if i <> 0 then begin
+ a " , "
+ end;
+ a (quot k);
+ a " : ";
+ encode_aux v buf ;
+ i + 1
+ ) map 0 in
+ a " }"
+ end
+
+
+let to_string (x : Ext_json_types.t) =
+ let buf = Buffer.create 1024 in
+ encode_aux x buf ;
+ Buffer.contents buf
+
+let to_channel (oc : out_channel) x =
+ let buf = Buffer.create 1024 in
+ encode_aux x buf ;
+ Buffer.output_buffer oc buf
end
-module Ext_list : sig
-#1 "ext_list.mli"
+module Ext_pervasives : sig
+#1 "ext_pervasives.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -9580,50 +9744,408 @@ module Ext_list : sig
-(** Extension to the standard library [List] module *)
-
-(** TODO some function are no efficiently implemented. *)
+(** Extension to standard library [Pervavives] module, safe to open
+ *)
-val filter_map : ('a -> 'b option) -> 'a list -> 'b list
+external reraise: exn -> 'a = "%reraise"
-val excludes : ('a -> bool) -> 'a list -> bool * 'a list
-val exclude_with_fact : ('a -> bool) -> 'a list -> 'a option * 'a list
-val exclude_with_fact2 :
- ('a -> bool) -> ('a -> bool) -> 'a list -> 'a option * 'a option * 'a list
-val same_length : 'a list -> 'b list -> bool
+val finally : 'a -> ('a -> 'c) -> ('a -> 'b) -> 'b
-val init : int -> (int -> 'a) -> 'a list
+val with_file_as_chan : string -> (out_channel -> 'a) -> 'a
-val take : int -> 'a list -> 'a list * 'a list
-val try_take : int -> 'a list -> 'a list * int * 'a list
+val with_file_as_pp : string -> (Format.formatter -> 'a) -> 'a
-val exclude_tail : 'a list -> 'a * 'a list
+val is_pos_pow : Int32.t -> int
-val length_compare : 'a list -> int -> [`Gt | `Eq | `Lt ]
+val failwithf : loc:string -> ('a, unit, string, 'b) format4 -> 'a
-(**
+val invalid_argf : ('a, unit, string, 'b) format4 -> 'a
- {[length xs = length ys + n ]}
- input n should be positive
- TODO: input checking
-*)
+val bad_argf : ('a, unit, string, 'b) format4 -> 'a
-val length_larger_than_n :
- int -> 'a list -> 'a list -> bool
-val filter_map2 : ('a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list
-val filter_map2i : (int -> 'a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list
+val dump : 'a -> string
+val pp_any : Format.formatter -> 'a -> unit
+external id : 'a -> 'a = "%identity"
-val filter_mapi : (int -> 'a -> 'b option) -> 'a list -> 'b list
+(** Copied from {!Btype.hash_variant}:
+ need sync up and add test case
+ *)
+val hash_variant : string -> int
-val flat_map2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list
+end = struct
+#1 "ext_pervasives.ml"
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-val flat_map_acc : ('a -> 'b list) -> 'b list -> 'a list -> 'b list
-val flat_map : ('a -> 'b list) -> 'a list -> 'b list
-(** for the last element the first element will be passed [true] *)
+
+
+
+external reraise: exn -> 'a = "%reraise"
+
+let finally v action f =
+ match f v with
+ | exception e ->
+ action v ;
+ reraise e
+ | e -> action v ; e
+
+let with_file_as_chan filename f =
+ finally (open_out_bin filename) close_out f
+
+let with_file_as_pp filename f =
+ finally (open_out_bin filename) close_out
+ (fun chan ->
+ let fmt = Format.formatter_of_out_channel chan in
+ let v = f fmt in
+ Format.pp_print_flush fmt ();
+ v
+ )
+
+
+let is_pos_pow n =
+ let module M = struct exception E end in
+ let rec aux c (n : Int32.t) =
+ if n <= 0l then -2
+ else if n = 1l then c
+ else if Int32.logand n 1l = 0l then
+ aux (c + 1) (Int32.shift_right n 1 )
+ else raise M.E in
+ try aux 0 n with M.E -> -1
+
+let failwithf ~loc fmt = Format.ksprintf (fun s -> failwith (loc ^ s))
+ fmt
+
+let invalid_argf fmt = Format.ksprintf invalid_arg fmt
+
+let bad_argf fmt = Format.ksprintf (fun x -> raise (Arg.Bad x ) ) fmt
+
+
+let rec dump r =
+ if Obj.is_int r then
+ string_of_int (Obj.magic r : int)
+ else (* Block. *)
+ let rec get_fields acc = function
+ | 0 -> acc
+ | n -> let n = n-1 in get_fields (Obj.field r n :: acc) n
+ in
+ let rec is_list r =
+ if Obj.is_int r then
+ r = Obj.repr 0 (* [] *)
+ else
+ let s = Obj.size r and t = Obj.tag r in
+ t = 0 && s = 2 && is_list (Obj.field r 1) (* h :: t *)
+ in
+ let rec get_list r =
+ if Obj.is_int r then
+ []
+ else
+ let h = Obj.field r 0 and t = get_list (Obj.field r 1) in
+ h :: t
+ in
+ let opaque name =
+ (* XXX In future, print the address of value 'r'. Not possible
+ * in pure OCaml at the moment. *)
+ "<" ^ name ^ ">"
+ in
+ let s = Obj.size r and t = Obj.tag r in
+ (* From the tag, determine the type of block. *)
+ match t with
+ | _ when is_list r ->
+ let fields = get_list r in
+ "[" ^ String.concat "; " (List.map dump fields) ^ "]"
+ | 0 ->
+ let fields = get_fields [] s in
+ "(" ^ String.concat ", " (List.map dump fields) ^ ")"
+ | x when x = Obj.lazy_tag ->
+ (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not
+ * clear if very large constructed values could have the same
+ * tag. XXX *)
+ opaque "lazy"
+ | x when x = Obj.closure_tag ->
+ opaque "closure"
+ | x when x = Obj.object_tag ->
+ let fields = get_fields [] s in
+ let _clasz, id, slots =
+ match fields with
+ | h::h'::t -> h, h', t
+ | _ -> assert false
+ in
+ (* No information on decoding the class (first field). So just print
+ * out the ID and the slots. *)
+ "Object #" ^ dump id ^ " (" ^ String.concat ", " (List.map dump slots) ^ ")"
+ | x when x = Obj.infix_tag ->
+ opaque "infix"
+ | x when x = Obj.forward_tag ->
+ opaque "forward"
+ | x when x < Obj.no_scan_tag ->
+ let fields = get_fields [] s in
+ "Tag" ^ string_of_int t ^
+ " (" ^ String.concat ", " (List.map dump fields) ^ ")"
+ | x when x = Obj.string_tag ->
+ "\"" ^ String.escaped (Obj.magic r : string) ^ "\""
+ | x when x = Obj.double_tag ->
+ string_of_float (Obj.magic r : float)
+ | x when x = Obj.abstract_tag ->
+ opaque "abstract"
+ | x when x = Obj.custom_tag ->
+ opaque "custom"
+ | x when x = Obj.custom_tag ->
+ opaque "final"
+ | x when x = Obj.double_array_tag ->
+ "[|"^
+ String.concat ";"
+ (Array.to_list (Array.map string_of_float (Obj.magic r : float array))) ^
+ "|]"
+ | _ ->
+ opaque (Printf.sprintf "unknown: tag %d size %d" t s)
+
+let dump v = dump (Obj.repr v)
+
+let pp_any fmt v =
+ Format.fprintf fmt "@[%s@]"
+ (dump v )
+external id : 'a -> 'a = "%identity"
+
+
+let hash_variant s =
+ let accu = ref 0 in
+ for i = 0 to String.length s - 1 do
+ accu := 223 * !accu + Char.code s.[i]
+ done;
+ (* reduce to 31 bits *)
+ accu := !accu land (1 lsl 31 - 1);
+ (* make it signed for 64 bits architectures *)
+ if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu
+
+
+end
+module Ounit_json_tests
+= struct
+#1 "ounit_json_tests.ml"
+
+let ((>::),
+ (>:::)) = OUnit.((>::),(>:::))
+
+open Ext_json_parse
+let (|?) m (key, cb) =
+ m |> Ext_json.test key cb
+
+let id_parsing_serializing x =
+ let normal_s =
+ Ext_json_write.to_string ( Ext_json_parse.parse_json_from_string x )
+ in
+ let normal_ss =
+ Ext_json_write.to_string
+ (Ext_json_parse.parse_json_from_string normal_s)
+ in
+ if normal_s <> normal_ss then
+ begin
+ prerr_endline "ERROR";
+ prerr_endline normal_s ;
+ prerr_endline normal_ss ;
+ end;
+ OUnit.assert_equal ~cmp:(fun (x:string) y -> x = y) normal_s normal_ss
+
+let id_parsing_x2 x =
+ let stru = Ext_json_parse.parse_json_from_string x in
+ let normal_s = Ext_json_write.to_string stru in
+ let normal_ss = (Ext_json_parse.parse_json_from_string normal_s) in
+ if Ext_json.equal stru normal_ss then
+ true
+ else begin
+ prerr_endline "ERROR";
+ prerr_endline normal_s;
+ Format.fprintf Format.err_formatter
+ "%a@.%a@." Ext_pervasives.pp_any stru Ext_pervasives.pp_any normal_ss;
+
+ prerr_endline (Ext_json_write.to_string normal_ss);
+ false
+ end
+
+let test_data =
+ [{|
+ {}
+ |};
+ {| [] |};
+ {| [1,2,3]|};
+ {| ["x", "y", 1,2,3 ]|};
+ {| { "x" : 3, "y" : "x", "z" : [1,2,3, "x"] }|};
+ {| {"x " : true , "y" : false , "z\"" : 1} |}
+ ]
+exception Parse_error
+let suites =
+ __FILE__
+ >:::
+ [
+
+ __LOC__ >:: begin fun _ ->
+ List.iter id_parsing_serializing test_data
+ end;
+
+ __LOC__ >:: begin fun _ ->
+ List.iteri (fun i x -> OUnit.assert_bool (__LOC__ ^ string_of_int i ) (id_parsing_x2 x)) test_data
+ end;
+ "empty_json" >:: begin fun _ ->
+ let v =parse_json_from_string "{}" in
+ match v with
+ | Obj {map = v} -> OUnit.assert_equal (String_map.is_empty v ) true
+ | _ -> OUnit.assert_failure "should be empty"
+ end
+ ;
+ "empty_arr" >:: begin fun _ ->
+ let v =parse_json_from_string "[]" in
+ match v with
+ | Arr {content = [||]} -> ()
+ | _ -> OUnit.assert_failure "should be empty"
+ end
+ ;
+ "empty trails" >:: begin fun _ ->
+ (OUnit.assert_raises Parse_error @@ fun _ ->
+ try parse_json_from_string {| [,]|} with _ -> raise Parse_error);
+ OUnit.assert_raises Parse_error @@ fun _ ->
+ try parse_json_from_string {| {,}|} with _ -> raise Parse_error
+ end;
+ "two trails" >:: begin fun _ ->
+ (OUnit.assert_raises Parse_error @@ fun _ ->
+ try parse_json_from_string {| [1,2,,]|} with _ -> raise Parse_error);
+ (OUnit.assert_raises Parse_error @@ fun _ ->
+ try parse_json_from_string {| { "x": 3, ,}|} with _ -> raise Parse_error)
+ end;
+
+ "two trails fail" >:: begin fun _ ->
+ (OUnit.assert_raises Parse_error @@ fun _ ->
+ try parse_json_from_string {| { "x": 3, 2 ,}|} with _ -> raise Parse_error)
+ end;
+
+ "trail comma obj" >:: begin fun _ ->
+ let v = parse_json_from_string {| { "x" : 3 , }|} in
+ let v1 = parse_json_from_string {| { "x" : 3 , }|} in
+ let test (v : Ext_json_types.t) =
+ match v with
+ | Obj {map = v} ->
+ v
+ |? ("x" , `Flo (fun x -> OUnit.assert_equal x "3"))
+ |> ignore
+ | _ -> OUnit.assert_failure "trail comma" in
+ test v ;
+ test v1
+ end
+ ;
+ "trail comma arr" >:: begin fun _ ->
+ let v = parse_json_from_string {| [ 1, 3, ]|} in
+ let v1 = parse_json_from_string {| [ 1, 3 ]|} in
+ let test (v : Ext_json_types.t) =
+ match v with
+ | Arr { content = [| Flo {flo = "1"} ; Flo { flo = "3"} |] } -> ()
+ | _ -> OUnit.assert_failure "trailing comma array" in
+ test v ;
+ test v1
+ end
+ ]
+
+end
+module Ext_list : sig
+#1 "ext_list.mli"
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+
+
+
+
+
+
+
+
+(** Extension to the standard library [List] module *)
+
+(** TODO some function are no efficiently implemented. *)
+
+val filter_map : ('a -> 'b option) -> 'a list -> 'b list
+
+val excludes : ('a -> bool) -> 'a list -> bool * 'a list
+val exclude_with_fact : ('a -> bool) -> 'a list -> 'a option * 'a list
+val exclude_with_fact2 :
+ ('a -> bool) -> ('a -> bool) -> 'a list -> 'a option * 'a option * 'a list
+val same_length : 'a list -> 'b list -> bool
+
+val init : int -> (int -> 'a) -> 'a list
+
+val take : int -> 'a list -> 'a list * 'a list
+val try_take : int -> 'a list -> 'a list * int * 'a list
+
+val exclude_tail : 'a list -> 'a * 'a list
+
+val length_compare : 'a list -> int -> [`Gt | `Eq | `Lt ]
+
+(**
+
+ {[length xs = length ys + n ]}
+ input n should be positive
+ TODO: input checking
+*)
+
+val length_larger_than_n :
+ int -> 'a list -> 'a list -> bool
+
+val filter_map2 : ('a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list
+
+val filter_map2i : (int -> 'a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list
+
+val filter_mapi : (int -> 'a -> 'b option) -> 'a list -> 'b list
+
+val flat_map2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list
+
+val flat_map_acc : ('a -> 'b list) -> 'b list -> 'a list -> 'b list
+val flat_map : ('a -> 'b list) -> 'a list -> 'b list
+
+
+(** for the last element the first element will be passed [true] *)
val fold_right2_last : (bool -> 'a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
@@ -10560,239 +11082,6 @@ let suites =
end
]
-end
-module Ext_pervasives : sig
-#1 "ext_pervasives.mli"
-(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
- *
- * This program is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published by
- * the Free Software Foundation, either version 3 of the License, or
- * (at your option) any later version.
- *
- * In addition to the permissions granted to you by the LGPL, you may combine
- * or link a "work that uses the Library" with a publicly distributed version
- * of this file to produce a combined library or application, then distribute
- * that combined work under the terms of your choosing, with no requirement
- * to comply with the obligations normally placed on you by section 4 of the
- * LGPL version 3 (or the corresponding section of a later version of the LGPL
- * should you choose to use a later version).
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public License
- * along with this program; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-
-
-
-
-
-
-
-
-(** Extension to standard library [Pervavives] module, safe to open
- *)
-
-external reraise: exn -> 'a = "%reraise"
-
-val finally : 'a -> ('a -> 'c) -> ('a -> 'b) -> 'b
-
-val with_file_as_chan : string -> (out_channel -> 'a) -> 'a
-
-val with_file_as_pp : string -> (Format.formatter -> 'a) -> 'a
-
-val is_pos_pow : Int32.t -> int
-
-val failwithf : loc:string -> ('a, unit, string, 'b) format4 -> 'a
-
-val invalid_argf : ('a, unit, string, 'b) format4 -> 'a
-
-val bad_argf : ('a, unit, string, 'b) format4 -> 'a
-
-
-
-val dump : 'a -> string
-val pp_any : Format.formatter -> 'a -> unit
-external id : 'a -> 'a = "%identity"
-
-(** Copied from {!Btype.hash_variant}:
- need sync up and add test case
- *)
-val hash_variant : string -> int
-
-end = struct
-#1 "ext_pervasives.ml"
-(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
- *
- * This program is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published by
- * the Free Software Foundation, either version 3 of the License, or
- * (at your option) any later version.
- *
- * In addition to the permissions granted to you by the LGPL, you may combine
- * or link a "work that uses the Library" with a publicly distributed version
- * of this file to produce a combined library or application, then distribute
- * that combined work under the terms of your choosing, with no requirement
- * to comply with the obligations normally placed on you by section 4 of the
- * LGPL version 3 (or the corresponding section of a later version of the LGPL
- * should you choose to use a later version).
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public License
- * along with this program; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-
-
-
-
-
-
-external reraise: exn -> 'a = "%reraise"
-
-let finally v action f =
- match f v with
- | exception e ->
- action v ;
- reraise e
- | e -> action v ; e
-
-let with_file_as_chan filename f =
- finally (open_out_bin filename) close_out f
-
-let with_file_as_pp filename f =
- finally (open_out_bin filename) close_out
- (fun chan ->
- let fmt = Format.formatter_of_out_channel chan in
- let v = f fmt in
- Format.pp_print_flush fmt ();
- v
- )
-
-
-let is_pos_pow n =
- let module M = struct exception E end in
- let rec aux c (n : Int32.t) =
- if n <= 0l then -2
- else if n = 1l then c
- else if Int32.logand n 1l = 0l then
- aux (c + 1) (Int32.shift_right n 1 )
- else raise M.E in
- try aux 0 n with M.E -> -1
-
-let failwithf ~loc fmt = Format.ksprintf (fun s -> failwith (loc ^ s))
- fmt
-
-let invalid_argf fmt = Format.ksprintf invalid_arg fmt
-
-let bad_argf fmt = Format.ksprintf (fun x -> raise (Arg.Bad x ) ) fmt
-
-
-let rec dump r =
- if Obj.is_int r then
- string_of_int (Obj.magic r : int)
- else (* Block. *)
- let rec get_fields acc = function
- | 0 -> acc
- | n -> let n = n-1 in get_fields (Obj.field r n :: acc) n
- in
- let rec is_list r =
- if Obj.is_int r then
- r = Obj.repr 0 (* [] *)
- else
- let s = Obj.size r and t = Obj.tag r in
- t = 0 && s = 2 && is_list (Obj.field r 1) (* h :: t *)
- in
- let rec get_list r =
- if Obj.is_int r then
- []
- else
- let h = Obj.field r 0 and t = get_list (Obj.field r 1) in
- h :: t
- in
- let opaque name =
- (* XXX In future, print the address of value 'r'. Not possible
- * in pure OCaml at the moment. *)
- "<" ^ name ^ ">"
- in
- let s = Obj.size r and t = Obj.tag r in
- (* From the tag, determine the type of block. *)
- match t with
- | _ when is_list r ->
- let fields = get_list r in
- "[" ^ String.concat "; " (List.map dump fields) ^ "]"
- | 0 ->
- let fields = get_fields [] s in
- "(" ^ String.concat ", " (List.map dump fields) ^ ")"
- | x when x = Obj.lazy_tag ->
- (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not
- * clear if very large constructed values could have the same
- * tag. XXX *)
- opaque "lazy"
- | x when x = Obj.closure_tag ->
- opaque "closure"
- | x when x = Obj.object_tag ->
- let fields = get_fields [] s in
- let _clasz, id, slots =
- match fields with
- | h::h'::t -> h, h', t
- | _ -> assert false
- in
- (* No information on decoding the class (first field). So just print
- * out the ID and the slots. *)
- "Object #" ^ dump id ^ " (" ^ String.concat ", " (List.map dump slots) ^ ")"
- | x when x = Obj.infix_tag ->
- opaque "infix"
- | x when x = Obj.forward_tag ->
- opaque "forward"
- | x when x < Obj.no_scan_tag ->
- let fields = get_fields [] s in
- "Tag" ^ string_of_int t ^
- " (" ^ String.concat ", " (List.map dump fields) ^ ")"
- | x when x = Obj.string_tag ->
- "\"" ^ String.escaped (Obj.magic r : string) ^ "\""
- | x when x = Obj.double_tag ->
- string_of_float (Obj.magic r : float)
- | x when x = Obj.abstract_tag ->
- opaque "abstract"
- | x when x = Obj.custom_tag ->
- opaque "custom"
- | x when x = Obj.custom_tag ->
- opaque "final"
- | x when x = Obj.double_array_tag ->
- "[|"^
- String.concat ";"
- (Array.to_list (Array.map string_of_float (Obj.magic r : float array))) ^
- "|]"
- | _ ->
- opaque (Printf.sprintf "unknown: tag %d size %d" t s)
-
-let dump v = dump (Obj.repr v)
-
-let pp_any fmt v =
- Format.fprintf fmt "@[%s@]"
- (dump v )
-external id : 'a -> 'a = "%identity"
-
-
-let hash_variant s =
- let accu = ref 0 in
- for i = 0 to String.length s - 1 do
- accu := 223 * !accu + Char.code s.[i]
- done;
- (* reduce to 31 bits *)
- accu := !accu land (1 lsl 31 - 1);
- (* make it signed for 64 bits architectures *)
- if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu
-
-
end
module Ext_filename : sig
#1 "ext_filename.mli"
@@ -13198,7 +13487,7 @@ let suites =
__LOC__ >:: begin fun _ ->
OUnit.assert_bool __LOC__ @@
List.for_all (fun x -> Ext_string.is_valid_source_name x = Good)
- ["x.ml"; "x.mli"; "x.re"; "x.rei"; "x.mll";
+ ["x.ml"; "x.mli"; "x.re"; "x.rei";
"A_x.ml"; "ab.ml"; "a_.ml"; "a__.ml";
"ax.ml"];
OUnit.assert_bool __LOC__ @@ not @@
diff --git a/jscomp/bin/bsb.ml b/jscomp/bin/bsb.ml
index cc16646b74..db82f92945 100644
--- a/jscomp/bin/bsb.ml
+++ b/jscomp/bin/bsb.ml
@@ -921,7 +921,8 @@ let is_valid_source_name name : check_result =
match check_any_suffix_case_then_chop name [
".ml";
".re";
- ".mli"; ".mll"; ".rei"
+ ".mli";
+ ".rei"
] with
| None -> Suffix_mismatch
| Some x ->
@@ -2781,6 +2782,289 @@ let header =
"// Generated by BUCKLESCRIPT VERSION 1.7.5, PLEASE EDIT WITH CARE"
let package_name = "bs-platform"
+end
+module Ext_array : sig
+#1 "ext_array.mli"
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+
+
+
+
+
+
+(** Some utilities for {!Array} operations *)
+val reverse_range : 'a array -> int -> int -> unit
+val reverse_in_place : 'a array -> unit
+val reverse : 'a array -> 'a array
+val reverse_of_list : 'a list -> 'a array
+
+val filter : ('a -> bool) -> 'a array -> 'a array
+
+val filter_map : ('a -> 'b option) -> 'a array -> 'b array
+
+val range : int -> int -> int array
+
+val map2i : (int -> 'a -> 'b -> 'c ) -> 'a array -> 'b array -> 'c array
+
+val to_list_map : ('a -> 'b option) -> 'a array -> 'b list
+
+val to_list_map_acc :
+ ('a -> 'b option) ->
+ 'a array ->
+ 'b list ->
+ 'b list
+
+val of_list_map : ('a -> 'b) -> 'a list -> 'b array
+
+val rfind_with_index : 'a array -> ('a -> 'b -> bool) -> 'b -> int
+
+
+type 'a split = [ `No_split | `Split of 'a array * 'a array ]
+
+val rfind_and_split :
+ 'a array ->
+ ('a -> 'b -> bool) ->
+ 'b -> 'a split
+
+val find_and_split :
+ 'a array ->
+ ('a -> 'b -> bool) ->
+ 'b -> 'a split
+
+val exists : ('a -> bool) -> 'a array -> bool
+
+val is_empty : 'a array -> bool
+
+val for_all2_no_exn :
+ ('a -> 'b -> bool) ->
+ 'a array ->
+ 'b array ->
+ bool
+end = struct
+#1 "ext_array.ml"
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+
+
+
+
+
+let reverse_range a i len =
+ if len = 0 then ()
+ else
+ for k = 0 to (len-1)/2 do
+ let t = Array.unsafe_get a (i+k) in
+ Array.unsafe_set a (i+k) ( Array.unsafe_get a (i+len-1-k));
+ Array.unsafe_set a (i+len-1-k) t;
+ done
+
+
+let reverse_in_place a =
+ reverse_range a 0 (Array.length a)
+
+let reverse a =
+ let b_len = Array.length a in
+ if b_len = 0 then [||] else
+ let b = Array.copy a in
+ for i = 0 to b_len - 1 do
+ Array.unsafe_set b i (Array.unsafe_get a (b_len - 1 -i ))
+ done;
+ b
+
+let reverse_of_list = function
+ | [] -> [||]
+ | hd::tl as l ->
+ let len = List.length l in
+ let a = Array.make len hd in
+ let rec fill i = function
+ | [] -> a
+ | hd::tl -> Array.unsafe_set a (len - i - 2) hd; fill (i+1) tl in
+ fill 0 tl
+
+let filter f a =
+ let arr_len = Array.length a in
+ let rec aux acc i =
+ if i = arr_len
+ then reverse_of_list acc
+ else
+ let v = Array.unsafe_get a i in
+ if f v then
+ aux (v::acc) (i+1)
+ else aux acc (i + 1)
+ in aux [] 0
+
+
+let filter_map (f : _ -> _ option) a =
+ let arr_len = Array.length a in
+ let rec aux acc i =
+ if i = arr_len
+ then reverse_of_list acc
+ else
+ let v = Array.unsafe_get a i in
+ match f v with
+ | Some v ->
+ aux (v::acc) (i+1)
+ | None ->
+ aux acc (i + 1)
+ in aux [] 0
+
+let range from to_ =
+ if from > to_ then invalid_arg "Ext_array.range"
+ else Array.init (to_ - from + 1) (fun i -> i + from)
+
+let map2i f a b =
+ let len = Array.length a in
+ if len <> Array.length b then
+ invalid_arg "Ext_array.map2i"
+ else
+ Array.mapi (fun i a -> f i a ( Array.unsafe_get b i )) a
+
+
+ let rec tolist_aux a f i res =
+ if i < 0 then res else
+ let v = Array.unsafe_get a i in
+ tolist_aux a f (i - 1)
+ (match f v with
+ | Some v -> v :: res
+ | None -> res)
+
+let to_list_map f a =
+ tolist_aux a f (Array.length a - 1) []
+
+let to_list_map_acc f a acc =
+ tolist_aux a f (Array.length a - 1) acc
+
+
+(* TODO: What would happen if [f] raise, memory leak? *)
+let of_list_map f a =
+ match a with
+ | [] -> [||]
+ | h::tl ->
+ let hd = f h in
+ let len = List.length tl + 1 in
+ let arr = Array.make len hd in
+ let rec fill i = function
+ | [] -> arr
+ | hd :: tl ->
+ Array.unsafe_set arr i (f hd);
+ fill (i + 1) tl in
+ fill 1 tl
+
+(**
+{[
+# rfind_with_index [|1;2;3|] (=) 2;;
+- : int = 1
+# rfind_with_index [|1;2;3|] (=) 1;;
+- : int = 0
+# rfind_with_index [|1;2;3|] (=) 3;;
+- : int = 2
+# rfind_with_index [|1;2;3|] (=) 4;;
+- : int = -1
+]}
+*)
+let rfind_with_index arr cmp v =
+ let len = Array.length arr in
+ let rec aux i =
+ if i < 0 then i
+ else if cmp (Array.unsafe_get arr i) v then i
+ else aux (i - 1) in
+ aux (len - 1)
+
+type 'a split = [ `No_split | `Split of 'a array * 'a array ]
+let rfind_and_split arr cmp v : _ split =
+ let i = rfind_with_index arr cmp v in
+ if i < 0 then
+ `No_split
+ else
+ `Split (Array.sub arr 0 i , Array.sub arr (i + 1 ) (Array.length arr - i - 1 ))
+
+
+let find_with_index arr cmp v =
+ let len = Array.length arr in
+ let rec aux i len =
+ if i >= len then -1
+ else if cmp (Array.unsafe_get arr i ) v then i
+ else aux (i + 1) len in
+ aux 0 len
+
+let find_and_split arr cmp v : _ split =
+ let i = find_with_index arr cmp v in
+ if i < 0 then
+ `No_split
+ else
+ `Split (Array.sub arr 0 i, Array.sub arr (i + 1 ) (Array.length arr - i - 1))
+
+(** TODO: available since 4.03, use {!Array.exists} *)
+
+let exists p a =
+ let n = Array.length a in
+ let rec loop i =
+ if i = n then false
+ else if p (Array.unsafe_get a i) then true
+ else loop (succ i) in
+ loop 0
+
+
+let is_empty arr =
+ Array.length arr = 0
+
+
+let rec unsafe_loop index len p xs ys =
+ if index >= len then true
+ else
+ p
+ (Array.unsafe_get xs index)
+ (Array.unsafe_get ys index) &&
+ unsafe_loop (succ index) len p xs ys
+
+let for_all2_no_exn p xs ys =
+ let len_xs = Array.length xs in
+ let len_ys = Array.length ys in
+ len_xs = len_ys &&
+ unsafe_loop 0 len_xs p xs ys
end
module Map_gen
= struct
@@ -3436,233 +3720,16 @@ module Ext_position : sig
type t = Lexing.position = {
- pos_fname : string ;
- pos_lnum : int ;
- pos_bol : int ;
- pos_cnum : int
-}
-
-
-val print : Format.formatter -> t -> unit
-end = struct
-#1 "ext_position.ml"
-(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
- *
- * This program is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published by
- * the Free Software Foundation, either version 3 of the License, or
- * (at your option) any later version.
- *
- * In addition to the permissions granted to you by the LGPL, you may combine
- * or link a "work that uses the Library" with a publicly distributed version
- * of this file to produce a combined library or application, then distribute
- * that combined work under the terms of your choosing, with no requirement
- * to comply with the obligations normally placed on you by section 4 of the
- * LGPL version 3 (or the corresponding section of a later version of the LGPL
- * should you choose to use a later version).
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public License
- * along with this program; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-
-
-type t = Lexing.position = {
- pos_fname : string ;
- pos_lnum : int ;
- pos_bol : int ;
- pos_cnum : int
-}
-
-
-let print fmt (pos : t) =
- Format.fprintf fmt "(%d,%d)" pos.pos_lnum (pos.pos_cnum - pos.pos_bol)
-
-
-
-
-
-
-end
-module Ext_json : sig
-#1 "ext_json.mli"
-(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
- *
- * This program is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published by
- * the Free Software Foundation, either version 3 of the License, or
- * (at your option) any later version.
- *
- * In addition to the permissions granted to you by the LGPL, you may combine
- * or link a "work that uses the Library" with a publicly distributed version
- * of this file to produce a combined library or application, then distribute
- * that combined work under the terms of your choosing, with no requirement
- * to comply with the obligations normally placed on you by section 4 of the
- * LGPL version 3 (or the corresponding section of a later version of the LGPL
- * should you choose to use a later version).
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public License
- * along with this program; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-
-
-type path = string list
-type status =
- | No_path
- | Found of Ext_json_types.t
- | Wrong_type of path
-
-
-type callback =
- [
- `Str of (string -> unit)
- | `Str_loc of (string -> Lexing.position -> unit)
- | `Flo of (string -> unit )
- | `Bool of (bool -> unit )
- | `Obj of (Ext_json_types.t String_map.t -> unit)
- | `Arr of (Ext_json_types.t array -> unit )
- | `Arr_loc of
- (Ext_json_types.t array -> Lexing.position -> Lexing.position -> unit)
- | `Null of (unit -> unit)
- | `Not_found of (unit -> unit)
- | `Id of (Ext_json_types.t -> unit )
- ]
-
-val test:
- ?fail:(unit -> unit) ->
- string -> callback
- -> Ext_json_types.t String_map.t
- -> Ext_json_types.t String_map.t
-
-val query : path -> Ext_json_types.t -> status
-
-val loc_of : Ext_json_types.t -> Ext_position.t
-
-end = struct
-#1 "ext_json.ml"
-
-
-type callback =
- [
- `Str of (string -> unit)
- | `Str_loc of (string -> Lexing.position -> unit)
- | `Flo of (string -> unit )
- | `Bool of (bool -> unit )
- | `Obj of (Ext_json_types.t String_map.t -> unit)
- | `Arr of (Ext_json_types.t array -> unit )
- | `Arr_loc of (Ext_json_types.t array -> Lexing.position -> Lexing.position -> unit)
- | `Null of (unit -> unit)
- | `Not_found of (unit -> unit)
- | `Id of (Ext_json_types.t -> unit )
- ]
-
-
-type path = string list
-
-type status =
- | No_path
- | Found of Ext_json_types.t
- | Wrong_type of path
-
-let test ?(fail=(fun () -> ())) key
- (cb : callback) (m : Ext_json_types.t String_map.t)
- =
- begin match String_map.find_exn key m, cb with
- | exception Not_found ->
- begin match cb with `Not_found f -> f ()
- | _ -> fail ()
- end
- | True _, `Bool cb -> cb true
- | False _, `Bool cb -> cb false
- | Flo {flo = s} , `Flo cb -> cb s
- | Obj {map = b} , `Obj cb -> cb b
- | Arr {content}, `Arr cb -> cb content
- | Arr {content; loc_start ; loc_end}, `Arr_loc cb ->
- cb content loc_start loc_end
- | Null _, `Null cb -> cb ()
- | Str {str = s }, `Str cb -> cb s
- | Str {str = s ; loc }, `Str_loc cb -> cb s loc
- | any , `Id cb -> cb any
- | _, _ -> fail ()
- end;
- m
-let query path (json : Ext_json_types.t ) =
- let rec aux acc paths json =
- match path with
- | [] -> Found json
- | p :: rest ->
- begin match json with
- | Obj {map = m} ->
- begin match String_map.find_exn p m with
- | m' -> aux (p::acc) rest m'
- | exception Not_found -> No_path
- end
- | _ -> Wrong_type acc
- end
- in aux [] path json
-
-
-let loc_of (x : Ext_json_types.t) =
- match x with
- | True p | False p | Null p -> p
- | Str p -> p.loc
- | Arr p -> p.loc_start
- | Obj p -> p.loc
- | Flo p -> p.loc
-
-
-end
-module Bsb_exception : sig
-#1 "bsb_exception.mli"
-(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
- *
- * This program is free software: you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published by
- * the Free Software Foundation, either version 3 of the License, or
- * (at your option) any later version.
- *
- * In addition to the permissions granted to you by the LGPL, you may combine
- * or link a "work that uses the Library" with a publicly distributed version
- * of this file to produce a combined library or application, then distribute
- * that combined work under the terms of your choosing, with no requirement
- * to comply with the obligations normally placed on you by section 4 of the
- * LGPL version 3 (or the corresponding section of a later version of the LGPL
- * should you choose to use a later version).
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public License
- * along with this program; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-
-
-
-type error =
- | Package_not_found of string * string option (* json file *)
-
-
-val error : error -> 'a
-
-val failf : ?loc:Ext_position.t -> ('a, unit, string, 'b) format4 -> 'a
-
-val failwith_config : Ext_json_types.t -> ('a, unit, string, 'b) format4 -> 'a
+ pos_fname : string ;
+ pos_lnum : int ;
+ pos_bol : int ;
+ pos_cnum : int
+}
-(* val expect_an_array_fmt : (string -> 'a, 'b, 'a) format *)
+val print : Format.formatter -> t -> unit
end = struct
-#1 "bsb_exception.ml"
+#1 "ext_position.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -3688,75 +3755,25 @@ end = struct
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+type t = Lexing.position = {
+ pos_fname : string ;
+ pos_lnum : int ;
+ pos_bol : int ;
+ pos_cnum : int
+}
-type error =
- | Package_not_found of string * string option (* json file *)
-
-
-exception Error of error
-
-let error err = raise (Error err)
-
-let to_string (x : error) =
- match x with
- | Package_not_found (name,json_opt) ->
- let in_json = match json_opt with None -> Ext_string.empty | Some x -> " in " ^ x in
- if Ext_string.equal name Bs_version.package_name then
- Printf.sprintf "Package bs-platform is not found %s , it is the basic package required, if you have it installed globally\n\
- Please run 'npm link bs-platform' to make it available " in_json
- else
- Printf.sprintf
- "BuckleScript package %s not found or built %s, if it is not built\n\
- Please run 'bsb -make-world', otherwise please install it " name in_json
-
-let () =
- Printexc.register_printer (fun x ->
- match x with
- | Error x ->
- Some (to_string x )
- | _ -> None
- )
-
-
-
-let failf ?loc fmt =
- let prefix =
- match loc with
- | None -> "Error "
- | Some x ->
- Format.asprintf "Error " Ext_position.print x in
- Format.ksprintf (fun s -> failwith (prefix ^ s)) fmt
-
-let expect_an_array_fmt : _ format = "%s expect an array"
-let failwith_config config fmt =
- let loc = Ext_json.loc_of config in
- failf ~loc fmt
-
-end
-module Bs_hash_stubs
-= struct
-#1 "bs_hash_stubs.ml"
-external hash_string : string -> int = "caml_bs_hash_string" "noalloc";;
-
-external hash_string_int : string -> int -> int = "caml_bs_hash_string_and_int" "noalloc";;
-external hash_string_small_int : string -> int -> int = "caml_bs_hash_string_and_small_int" "noalloc";;
+let print fmt (pos : t) =
+ Format.fprintf fmt "(%d,%d)" pos.pos_lnum (pos.pos_cnum - pos.pos_bol)
-external hash_stamp_and_name : int -> string -> int = "caml_bs_hash_stamp_and_name" "noalloc";;
-external hash_small_int : int -> int = "caml_bs_hash_small_int" "noalloc";;
-external hash_int : int -> int = "caml_bs_hash_int" "noalloc";;
-external string_length_based_compare : string -> string -> int = "caml_string_length_based_compare" "noalloc";;
-external
- int_unsafe_blit :
- int array -> int -> int array -> int -> int -> unit = "caml_int_array_blit" "noalloc";;
end
-module Ext_util : sig
-#1 "ext_util.mli"
+module Ext_json : sig
+#1 "ext_json.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -3782,15 +3799,43 @@ module Ext_util : sig
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-
-val power_2_above : int -> int -> int
+type path = string list
+type status =
+ | No_path
+ | Found of Ext_json_types.t
+ | Wrong_type of path
-val stats_to_string : Hashtbl.statistics -> string
+type callback =
+ [
+ `Str of (string -> unit)
+ | `Str_loc of (string -> Lexing.position -> unit)
+ | `Flo of (string -> unit )
+ | `Bool of (bool -> unit )
+ | `Obj of (Ext_json_types.t String_map.t -> unit)
+ | `Arr of (Ext_json_types.t array -> unit )
+ | `Arr_loc of
+ (Ext_json_types.t array -> Lexing.position -> Lexing.position -> unit)
+ | `Null of (unit -> unit)
+ | `Not_found of (unit -> unit)
+ | `Id of (Ext_json_types.t -> unit )
+ ]
+
+val test:
+ ?fail:(unit -> unit) ->
+ string -> callback
+ -> Ext_json_types.t String_map.t
+ -> Ext_json_types.t String_map.t
+
+val query : path -> Ext_json_types.t -> status
+
+val loc_of : Ext_json_types.t -> Ext_position.t
+
+val equal : Ext_json_types.t -> Ext_json_types.t -> bool
end = struct
-#1 "ext_util.ml"
+#1 "ext_json.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
- *
+ *
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
@@ -3808,252 +3853,171 @@ end = struct
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
- *
+ *
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-(**
- {[
- (power_2_above 16 63 = 64)
- (power_2_above 16 76 = 128)
- ]}
-*)
-let rec power_2_above x n =
- if x >= n then x
- else if x * 2 > Sys.max_array_length then x
- else power_2_above (x * 2) n
-
-
-let stats_to_string ({num_bindings; num_buckets; max_bucket_length; bucket_histogram} : Hashtbl.statistics) =
- Printf.sprintf
- "bindings: %d,buckets: %d, longest: %d, hist:[%s]"
- num_bindings
- num_buckets
- max_bucket_length
- (String.concat "," (Array.to_list (Array.map string_of_int bucket_histogram)))
-end
-module Hashtbl_gen
-= struct
-#1 "hashtbl_gen.ml"
-(***********************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* Hash tables *)
-
-
-
-module type S = sig
- type key
- type 'a t
- val create: int -> 'a t
- val clear: 'a t -> unit
- val reset: 'a t -> unit
- val copy: 'a t -> 'a t
- val add: 'a t -> key -> 'a -> unit
- val modify_or_init: 'a t -> key -> ('a -> unit) -> (unit -> 'a) -> unit
- val remove: 'a t -> key -> unit
- val find_exn: 'a t -> key -> 'a
- val find_all: 'a t -> key -> 'a list
- val find_opt: 'a t -> key -> 'a option
-
- (** return the key found in the hashtbl.
- Use case: when you find the key existed in hashtbl,
- you want to use the one stored in the hashtbl.
- (they are semantically equivlanent, but may have other information different)
- *)
- val find_key_opt: 'a t -> key -> key option
-
- val find_default: 'a t -> key -> 'a -> 'a
-
- val replace: 'a t -> key -> 'a -> unit
- val mem: 'a t -> key -> bool
- val iter: (key -> 'a -> unit) -> 'a t -> unit
- val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
- val length: 'a t -> int
- val stats: 'a t -> Hashtbl.statistics
- val of_list2: key list -> 'a list -> 'a t
-end
-
-(* We do dynamic hashing, and resize the table and rehash the elements
- when buckets become too long. *)
-
-type ('a, 'b) t =
- { mutable size: int; (* number of entries *)
- mutable data: ('a, 'b) bucketlist array; (* the buckets *)
- mutable seed: int; (* for randomization *)
- initial_size: int; (* initial array size *)
- }
-
-and ('a, 'b) bucketlist =
- | Empty
- | Cons of 'a * 'b * ('a, 'b) bucketlist
-
-
-let create initial_size =
- let s = Ext_util.power_2_above 16 initial_size in
- { initial_size = s; size = 0; seed = 0; data = Array.make s Empty }
-
-let clear h =
- h.size <- 0;
- let len = Array.length h.data in
- for i = 0 to len - 1 do
- h.data.(i) <- Empty
- done
-
-let reset h =
- h.size <- 0;
- h.data <- Array.make h.initial_size Empty
+type callback =
+ [
+ `Str of (string -> unit)
+ | `Str_loc of (string -> Lexing.position -> unit)
+ | `Flo of (string -> unit )
+ | `Bool of (bool -> unit )
+ | `Obj of (Ext_json_types.t String_map.t -> unit)
+ | `Arr of (Ext_json_types.t array -> unit )
+ | `Arr_loc of (Ext_json_types.t array -> Lexing.position -> Lexing.position -> unit)
+ | `Null of (unit -> unit)
+ | `Not_found of (unit -> unit)
+ | `Id of (Ext_json_types.t -> unit )
+ ]
-let copy h = { h with data = Array.copy h.data }
+type path = string list
-let length h = h.size
+type status =
+ | No_path
+ | Found of Ext_json_types.t
+ | Wrong_type of path
-let resize indexfun h =
- let odata = h.data in
- let osize = Array.length odata in
- let nsize = osize * 2 in
- if nsize < Sys.max_array_length then begin
- let ndata = Array.make nsize Empty in
- h.data <- ndata; (* so that indexfun sees the new bucket count *)
- let rec insert_bucket = function
- Empty -> ()
- | Cons(key, data, rest) ->
- insert_bucket rest; (* preserve original order of elements *)
- let nidx = indexfun h key in
- ndata.(nidx) <- Cons(key, data, ndata.(nidx)) in
- for i = 0 to osize - 1 do
- insert_bucket (Array.unsafe_get odata i)
- done
- end
+let test ?(fail=(fun () -> ())) key
+ (cb : callback) (m : Ext_json_types.t String_map.t)
+ =
+ begin match String_map.find_exn key m, cb with
+ | exception Not_found ->
+ begin match cb with `Not_found f -> f ()
+ | _ -> fail ()
+ end
+ | True _, `Bool cb -> cb true
+ | False _, `Bool cb -> cb false
+ | Flo {flo = s} , `Flo cb -> cb s
+ | Obj {map = b} , `Obj cb -> cb b
+ | Arr {content}, `Arr cb -> cb content
+ | Arr {content; loc_start ; loc_end}, `Arr_loc cb ->
+ cb content loc_start loc_end
+ | Null _, `Null cb -> cb ()
+ | Str {str = s }, `Str cb -> cb s
+ | Str {str = s ; loc }, `Str_loc cb -> cb s loc
+ | any , `Id cb -> cb any
+ | _, _ -> fail ()
+ end;
+ m
+let query path (json : Ext_json_types.t ) =
+ let rec aux acc paths json =
+ match path with
+ | [] -> Found json
+ | p :: rest ->
+ begin match json with
+ | Obj {map = m} ->
+ begin match String_map.find_exn p m with
+ | m' -> aux (p::acc) rest m'
+ | exception Not_found -> No_path
+ end
+ | _ -> Wrong_type acc
+ end
+ in aux [] path json
+let loc_of (x : Ext_json_types.t) =
+ match x with
+ | True p | False p | Null p -> p
+ | Str p -> p.loc
+ | Arr p -> p.loc_start
+ | Obj p -> p.loc
+ | Flo p -> p.loc
-let iter f h =
- let rec do_bucket = function
- | Empty ->
- ()
- | Cons(k, d, rest) ->
- f k d; do_bucket rest in
- let d = h.data in
- for i = 0 to Array.length d - 1 do
- do_bucket (Array.unsafe_get d i)
- done
-let fold f h init =
- let rec do_bucket b accu =
- match b with
- Empty ->
- accu
- | Cons(k, d, rest) ->
- do_bucket rest (f k d accu) in
- let d = h.data in
- let accu = ref init in
- for i = 0 to Array.length d - 1 do
- accu := do_bucket d.(i) !accu
- done;
- !accu
+let rec equal
+ (x : Ext_json_types.t)
+ (y : Ext_json_types.t) =
+ match x with
+ | Null _ -> (* [%p? Null _ ] *)
+ begin match y with
+ | Null _ -> true
+ | _ -> false end
+ | Str {str } ->
+ begin match y with
+ | Str {str = str2} -> str = str2
+ | _ -> false end
+ | Flo {flo}
+ ->
+ begin match y with
+ | Flo {flo = flo2} ->
+ flo = flo2
+ | _ -> false
+ end
+ | True _ ->
+ begin match y with
+ | True _ -> true
+ | _ -> false
+ end
+ | False _ ->
+ begin match y with
+ | False _ -> true
+ | _ -> false
+ end
+ | Arr {content}
+ ->
+ begin match y with
+ | Arr {content = content2}
+ ->
+ Ext_array.for_all2_no_exn equal content content2
+ | _ -> false
+ end
-let rec bucket_length accu = function
- | Empty -> accu
- | Cons(_, _, rest) -> bucket_length (accu + 1) rest
+ | Obj {map} ->
+ begin match y with
+ | Obj { map = map2} ->
+ String_map.equal equal map map2
+ | _ -> false
+ end
-let stats h =
- let mbl =
- Array.fold_left (fun m b -> max m (bucket_length 0 b)) 0 h.data in
- let histo = Array.make (mbl + 1) 0 in
- Array.iter
- (fun b ->
- let l = bucket_length 0 b in
- histo.(l) <- histo.(l) + 1)
- h.data;
- {Hashtbl.
- num_bindings = h.size;
- num_buckets = Array.length h.data;
- max_bucket_length = mbl;
- bucket_histogram = histo }
+end
+module Bsb_exception : sig
+#1 "bsb_exception.mli"
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-let rec small_bucket_mem eq key (lst : _ bucketlist) =
- match lst with
- | Empty -> false
- | Cons(k1,_,rest1) ->
- eq key k1 ||
- match rest1 with
- | Empty -> false
- | Cons(k2,_,rest2) ->
- eq key k2 ||
- match rest2 with
- | Empty -> false
- | Cons(k3,_,rest3) ->
- eq key k3 ||
- small_bucket_mem eq key rest3
+type error =
+ | Package_not_found of string * string option (* json file *)
-let rec small_bucket_opt eq key (lst : _ bucketlist) : _ option =
- match lst with
- | Empty -> None
- | Cons(k1,d1,rest1) ->
- if eq key k1 then Some d1 else
- match rest1 with
- | Empty -> None
- | Cons(k2,d2,rest2) ->
- if eq key k2 then Some d2 else
- match rest2 with
- | Empty -> None
- | Cons(k3,d3,rest3) ->
- if eq key k3 then Some d3 else
- small_bucket_opt eq key rest3
+val error : error -> 'a
-let rec small_bucket_key_opt eq key (lst : _ bucketlist) : _ option =
- match lst with
- | Empty -> None
- | Cons(k1,d1,rest1) ->
- if eq key k1 then Some k1 else
- match rest1 with
- | Empty -> None
- | Cons(k2,d2,rest2) ->
- if eq key k2 then Some k2 else
- match rest2 with
- | Empty -> None
- | Cons(k3,d3,rest3) ->
- if eq key k3 then Some k3 else
- small_bucket_key_opt eq key rest3
+val failf : ?loc:Ext_position.t -> ('a, unit, string, 'b) format4 -> 'a
+val failwith_config : Ext_json_types.t -> ('a, unit, string, 'b) format4 -> 'a
-let rec small_bucket_default eq key default (lst : _ bucketlist) =
- match lst with
- | Empty -> default
- | Cons(k1,d1,rest1) ->
- if eq key k1 then d1 else
- match rest1 with
- | Empty -> default
- | Cons(k2,d2,rest2) ->
- if eq key k2 then d2 else
- match rest2 with
- | Empty -> default
- | Cons(k3,d3,rest3) ->
- if eq key k3 then d3 else
- small_bucket_default eq key default rest3
+(* val expect_an_array_fmt : (string -> 'a, 'b, 'a) format *)
-end
-module String_hashtbl : sig
-#1 "string_hashtbl.mli"
+end = struct
+#1 "bsb_exception.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
- *
+ *
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
@@ -4071,159 +4035,113 @@ module String_hashtbl : sig
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
- *
+ *
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-include Hashtbl_gen.S with type key = string
+type error =
+ | Package_not_found of string * string option (* json file *)
+exception Error of error
-end = struct
-#1 "string_hashtbl.ml"
-# 9 "ext/hashtbl.cppo.ml"
-type key = string
-type 'a t = (key, 'a) Hashtbl_gen.t
-let key_index (h : _ t ) (key : key) =
- (Bs_hash_stubs.hash_string key ) land (Array.length h.data - 1)
-let eq_key = Ext_string.equal
+let error err = raise (Error err)
-# 33
-type ('a, 'b) bucketlist = ('a,'b) Hashtbl_gen.bucketlist
-let create = Hashtbl_gen.create
-let clear = Hashtbl_gen.clear
-let reset = Hashtbl_gen.reset
-let copy = Hashtbl_gen.copy
-let iter = Hashtbl_gen.iter
-let fold = Hashtbl_gen.fold
-let length = Hashtbl_gen.length
-let stats = Hashtbl_gen.stats
+let to_string (x : error) =
+ match x with
+ | Package_not_found (name,json_opt) ->
+ let in_json = match json_opt with None -> Ext_string.empty | Some x -> " in " ^ x in
+ if Ext_string.equal name Bs_version.package_name then
+ Printf.sprintf "Package bs-platform is not found %s , it is the basic package required, if you have it installed globally\n\
+ Please run 'npm link bs-platform' to make it available " in_json
+ else
+ Printf.sprintf
+ "BuckleScript package %s not found or built %s, if it is not built\n\
+ Please run 'bsb -make-world', otherwise please install it " name in_json
+let () =
+ Printexc.register_printer (fun x ->
+ match x with
+ | Error x ->
+ Some (to_string x )
+ | _ -> None
+ )
-let add (h : _ t) key info =
- let i = key_index h key in
- let h_data = h.data in
- Array.unsafe_set h_data i (Cons(key, info, (Array.unsafe_get h_data i)));
- h.size <- h.size + 1;
- if h.size > Array.length h_data lsl 1 then Hashtbl_gen.resize key_index h
-(* after upgrade to 4.04 we should provide an efficient [replace_or_init] *)
-let modify_or_init (h : _ t) key modf default =
- let rec find_bucket (bucketlist : _ bucketlist) =
- match bucketlist with
- | Cons(k,i,next) ->
- if eq_key k key then begin modf i; false end
- else find_bucket next
- | Empty -> true in
- let i = key_index h key in
- let h_data = h.data in
- if find_bucket (Array.unsafe_get h_data i) then
- begin
- Array.unsafe_set h_data i (Cons(key,default (), Array.unsafe_get h_data i));
- h.size <- h.size + 1 ;
- if h.size > Array.length h_data lsl 1 then Hashtbl_gen.resize key_index h
- end
+let failf ?loc fmt =
+ let prefix =
+ match loc with
+ | None -> "Error "
+ | Some x ->
+ Format.asprintf "Error " Ext_position.print x in
+ Format.ksprintf (fun s -> failwith (prefix ^ s)) fmt
+let expect_an_array_fmt : _ format = "%s expect an array"
+let failwith_config config fmt =
+ let loc = Ext_json.loc_of config in
+ failf ~loc fmt
-let rec remove_bucket key (h : _ t) (bucketlist : _ bucketlist) : _ bucketlist =
- match bucketlist with
- | Empty ->
- Empty
- | Cons(k, i, next) ->
- if eq_key k key
- then begin h.size <- h.size - 1; next end
- else Cons(k, i, remove_bucket key h next)
+end
+module Bs_hash_stubs
+= struct
+#1 "bs_hash_stubs.ml"
+external hash_string : string -> int = "caml_bs_hash_string" "noalloc";;
-let remove (h : _ t ) key =
- let i = key_index h key in
- let h_data = h.data in
- let old_h_szie = h.size in
- let new_bucket = remove_bucket key h (Array.unsafe_get h_data i) in
- if old_h_szie <> h.size then
- Array.unsafe_set h_data i new_bucket
+external hash_string_int : string -> int -> int = "caml_bs_hash_string_and_int" "noalloc";;
-let rec find_rec key (bucketlist : _ bucketlist) = match bucketlist with
- | Empty ->
- raise Not_found
- | Cons(k, d, rest) ->
- if eq_key key k then d else find_rec key rest
+external hash_string_small_int : string -> int -> int = "caml_bs_hash_string_and_small_int" "noalloc";;
-let find_exn (h : _ t) key =
- match Array.unsafe_get h.data (key_index h key) with
- | Empty -> raise Not_found
- | Cons(k1, d1, rest1) ->
- if eq_key key k1 then d1 else
- match rest1 with
- | Empty -> raise Not_found
- | Cons(k2, d2, rest2) ->
- if eq_key key k2 then d2 else
- match rest2 with
- | Empty -> raise Not_found
- | Cons(k3, d3, rest3) ->
- if eq_key key k3 then d3 else find_rec key rest3
+external hash_stamp_and_name : int -> string -> int = "caml_bs_hash_stamp_and_name" "noalloc";;
-let find_opt (h : _ t) key =
- Hashtbl_gen.small_bucket_opt eq_key key (Array.unsafe_get h.data (key_index h key))
+external hash_small_int : int -> int = "caml_bs_hash_small_int" "noalloc";;
-let find_key_opt (h : _ t) key =
- Hashtbl_gen.small_bucket_key_opt eq_key key (Array.unsafe_get h.data (key_index h key))
-
-let find_default (h : _ t) key default =
- Hashtbl_gen.small_bucket_default eq_key key default (Array.unsafe_get h.data (key_index h key))
-let find_all (h : _ t) key =
- let rec find_in_bucket (bucketlist : _ bucketlist) = match bucketlist with
- | Empty ->
- []
- | Cons(k, d, rest) ->
- if eq_key k key
- then d :: find_in_bucket rest
- else find_in_bucket rest in
- find_in_bucket (Array.unsafe_get h.data (key_index h key))
+external hash_int : int -> int = "caml_bs_hash_int" "noalloc";;
-let replace h key info =
- let rec replace_bucket (bucketlist : _ bucketlist) : _ bucketlist = match bucketlist with
- | Empty ->
- raise_notrace Not_found
- | Cons(k, i, next) ->
- if eq_key k key
- then Cons(key, info, next)
- else Cons(k, i, replace_bucket next) in
- let i = key_index h key in
- let h_data = h.data in
- let l = Array.unsafe_get h_data i in
- try
- Array.unsafe_set h_data i (replace_bucket l)
- with Not_found ->
- begin
- Array.unsafe_set h_data i (Cons(key, info, l));
- h.size <- h.size + 1;
- if h.size > Array.length h_data lsl 1 then Hashtbl_gen.resize key_index h;
- end
+external string_length_based_compare : string -> string -> int = "caml_string_length_based_compare" "noalloc";;
-let mem (h : _ t) key =
- let rec mem_in_bucket (bucketlist : _ bucketlist) = match bucketlist with
- | Empty ->
- false
- | Cons(k, d, rest) ->
- eq_key k key || mem_in_bucket rest in
- mem_in_bucket (Array.unsafe_get h.data (key_index h key))
+external
+ int_unsafe_blit :
+ int array -> int -> int array -> int -> int -> unit = "caml_int_array_blit" "noalloc";;
+end
+module Ext_util : sig
+#1 "ext_util.mli"
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-let of_list2 ks vs =
- let len = List.length ks in
- let map = create len in
- List.iter2 (fun k v -> add map k v) ks vs ;
- map
+
+val power_2_above : int -> int -> int
-end
-module Bsb_pkg : sig
-#1 "bsb_pkg.mli"
+val stats_to_string : Hashtbl.statistics -> string
+end = struct
+#1 "ext_util.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -4248,125 +4166,245 @@ module Bsb_pkg : sig
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+(**
+ {[
+ (power_2_above 16 63 = 64)
+ (power_2_above 16 76 = 128)
+ ]}
+*)
+let rec power_2_above x n =
+ if x >= n then x
+ else if x * 2 > Sys.max_array_length then x
+ else power_2_above (x * 2) n
-(** [resolve cwd module_name],
- [cwd] is current working directory, absolute path
- Trying to find paths to load [module_name]
- it is sepcialized for option [-bs-package-include] which requires
- [npm_package_name/lib/ocaml]
- it relies on [npm_config_prefix] env variable for global npm modules
-*)
+let stats_to_string ({num_bindings; num_buckets; max_bucket_length; bucket_histogram} : Hashtbl.statistics) =
+ Printf.sprintf
+ "bindings: %d,buckets: %d, longest: %d, hist:[%s]"
+ num_bindings
+ num_buckets
+ max_bucket_length
+ (String.concat "," (Array.to_list (Array.map string_of_int bucket_histogram)))
+end
+module Hashtbl_gen
+= struct
+#1 "hashtbl_gen.ml"
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU Library General Public License, with *)
+(* the special exception on linking described in file ../LICENSE. *)
+(* *)
+(***********************************************************************)
-(** @raise when not found *)
-val resolve_bs_package :
- cwd:string -> string -> string
+(* Hash tables *)
+
+
+
+module type S = sig
+ type key
+ type 'a t
+ val create: int -> 'a t
+ val clear: 'a t -> unit
+ val reset: 'a t -> unit
+ val copy: 'a t -> 'a t
+ val add: 'a t -> key -> 'a -> unit
+ val modify_or_init: 'a t -> key -> ('a -> unit) -> (unit -> 'a) -> unit
+ val remove: 'a t -> key -> unit
+ val find_exn: 'a t -> key -> 'a
+ val find_all: 'a t -> key -> 'a list
+ val find_opt: 'a t -> key -> 'a option
+
+ (** return the key found in the hashtbl.
+ Use case: when you find the key existed in hashtbl,
+ you want to use the one stored in the hashtbl.
+ (they are semantically equivlanent, but may have other information different)
+ *)
+ val find_key_opt: 'a t -> key -> key option
+
+ val find_default: 'a t -> key -> 'a -> 'a
+
+ val replace: 'a t -> key -> 'a -> unit
+ val mem: 'a t -> key -> bool
+ val iter: (key -> 'a -> unit) -> 'a t -> unit
+ val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ val length: 'a t -> int
+ val stats: 'a t -> Hashtbl.statistics
+ val of_list2: key list -> 'a list -> 'a t
+end
+
+(* We do dynamic hashing, and resize the table and rehash the elements
+ when buckets become too long. *)
+
+type ('a, 'b) t =
+ { mutable size: int; (* number of entries *)
+ mutable data: ('a, 'b) bucketlist array; (* the buckets *)
+ mutable seed: int; (* for randomization *)
+ initial_size: int; (* initial array size *)
+ }
+
+and ('a, 'b) bucketlist =
+ | Empty
+ | Cons of 'a * 'b * ('a, 'b) bucketlist
+
+
+let create initial_size =
+ let s = Ext_util.power_2_above 16 initial_size in
+ { initial_size = s; size = 0; seed = 0; data = Array.make s Empty }
+
+let clear h =
+ h.size <- 0;
+ let len = Array.length h.data in
+ for i = 0 to len - 1 do
+ h.data.(i) <- Empty
+ done
+
+let reset h =
+ h.size <- 0;
+ h.data <- Array.make h.initial_size Empty
+
+
+let copy h = { h with data = Array.copy h.data }
+
+let length h = h.size
+
+let resize indexfun h =
+ let odata = h.data in
+ let osize = Array.length odata in
+ let nsize = osize * 2 in
+ if nsize < Sys.max_array_length then begin
+ let ndata = Array.make nsize Empty in
+ h.data <- ndata; (* so that indexfun sees the new bucket count *)
+ let rec insert_bucket = function
+ Empty -> ()
+ | Cons(key, data, rest) ->
+ insert_bucket rest; (* preserve original order of elements *)
+ let nidx = indexfun h key in
+ ndata.(nidx) <- Cons(key, data, ndata.(nidx)) in
+ for i = 0 to osize - 1 do
+ insert_bucket (Array.unsafe_get odata i)
+ done
+ end
+
+
+
+let iter f h =
+ let rec do_bucket = function
+ | Empty ->
+ ()
+ | Cons(k, d, rest) ->
+ f k d; do_bucket rest in
+ let d = h.data in
+ for i = 0 to Array.length d - 1 do
+ do_bucket (Array.unsafe_get d i)
+ done
+let fold f h init =
+ let rec do_bucket b accu =
+ match b with
+ Empty ->
+ accu
+ | Cons(k, d, rest) ->
+ do_bucket rest (f k d accu) in
+ let d = h.data in
+ let accu = ref init in
+ for i = 0 to Array.length d - 1 do
+ accu := do_bucket d.(i) !accu
+ done;
+ !accu
+let rec bucket_length accu = function
+ | Empty -> accu
+ | Cons(_, _, rest) -> bucket_length (accu + 1) rest
-end = struct
-#1 "bsb_pkg.ml"
+let stats h =
+ let mbl =
+ Array.fold_left (fun m b -> max m (bucket_length 0 b)) 0 h.data in
+ let histo = Array.make (mbl + 1) 0 in
+ Array.iter
+ (fun b ->
+ let l = bucket_length 0 b in
+ histo.(l) <- histo.(l) + 1)
+ h.data;
+ {Hashtbl.
+ num_bindings = h.size;
+ num_buckets = Array.length h.data;
+ max_bucket_length = mbl;
+ bucket_histogram = histo }
-let (//) = Filename.concat
+let rec small_bucket_mem eq key (lst : _ bucketlist) =
+ match lst with
+ | Empty -> false
+ | Cons(k1,_,rest1) ->
+ eq key k1 ||
+ match rest1 with
+ | Empty -> false
+ | Cons(k2,_,rest2) ->
+ eq key k2 ||
+ match rest2 with
+ | Empty -> false
+ | Cons(k3,_,rest3) ->
+ eq key k3 ||
+ small_bucket_mem eq key rest3
-(** It makes sense to have this function raise, when [bsb] could not resolve a package, it used to mean
- a failure
-*)
-let resolve_bs_package
- ~cwd
- name =
- let marker = Literals.bsconfig_json in
- let sub_path = name // marker in
- let rec aux cwd =
- let abs_marker = cwd // Literals.node_modules // sub_path in
- if Sys.file_exists abs_marker then (* Some *) (Filename.dirname abs_marker)
- else
- let cwd' = Filename.dirname cwd in (* TODO: may non-terminating when see symlinks *)
- if String.length cwd' < String.length cwd then
- aux cwd'
- else
- try
- let abs_marker =
- Sys.getenv "npm_config_prefix"
- // "lib" // Literals.node_modules // sub_path in
- if Sys.file_exists abs_marker
- then
- Filename.dirname abs_marker
- else
- begin
- Format.fprintf Format.err_formatter
- "@{Package not found: resolving package %s in %s @}@." name cwd ;
- Bsb_exception.error (Package_not_found (name, None))
- end
- with
- Not_found ->
- begin
- Format.fprintf Format.err_formatter
- "@{Package not found: resolving package %s in %s @}@." name cwd ;
- Bsb_exception.error (Package_not_found (name,None))
- end
- in
- aux cwd
+let rec small_bucket_opt eq key (lst : _ bucketlist) : _ option =
+ match lst with
+ | Empty -> None
+ | Cons(k1,d1,rest1) ->
+ if eq key k1 then Some d1 else
+ match rest1 with
+ | Empty -> None
+ | Cons(k2,d2,rest2) ->
+ if eq key k2 then Some d2 else
+ match rest2 with
+ | Empty -> None
+ | Cons(k3,d3,rest3) ->
+ if eq key k3 then Some d3 else
+ small_bucket_opt eq key rest3
-let cache = String_hashtbl.create 0
+let rec small_bucket_key_opt eq key (lst : _ bucketlist) : _ option =
+ match lst with
+ | Empty -> None
+ | Cons(k1,d1,rest1) ->
+ if eq key k1 then Some k1 else
+ match rest1 with
+ | Empty -> None
+ | Cons(k2,d2,rest2) ->
+ if eq key k2 then Some k2 else
+ match rest2 with
+ | Empty -> None
+ | Cons(k3,d3,rest3) ->
+ if eq key k3 then Some k3 else
+ small_bucket_key_opt eq key rest3
-(** TODO: collect all warnings and print later *)
-let resolve_bs_package ~cwd package =
- match String_hashtbl.find_opt cache package with
- | None ->
- let result = resolve_bs_package ~cwd package in
- Format.fprintf Format.std_formatter "@{Package@} %s -> %s@." package result ;
- String_hashtbl.add cache package result ;
- result
- | Some x
- ->
- let result = resolve_bs_package ~cwd package in
- if result <> x then
- begin
- Format.fprintf Format.err_formatter
- "@{Duplicated package:@} %s %s (chosen) vs %s in %s @." package x result cwd;
- end;
- x
-(** The package does not need to be a bspackage
- example:
- {[
- resolve_npm_package_file ~cwd "reason/refmt";;
- resolve_npm_package_file ~cwd "reason/refmt/xx/yy"
- ]}
- It also returns the path name
- Note the input [sub_path] is already converted to physical meaning path according to OS
-*)
-(* let resolve_npm_package_file ~cwd sub_path = *)
-(* let rec aux cwd = *)
-(* let abs_marker = cwd // Literals.node_modules // sub_path in *)
-(* if Sys.file_exists abs_marker then Some abs_marker *)
-(* else *)
-(* let cwd' = Filename.dirname cwd in *)
-(* if String.length cwd' < String.length cwd then *)
-(* aux cwd' *)
-(* else *)
-(* try *)
-(* let abs_marker = *)
-(* Sys.getenv "npm_config_prefix" *)
-(* // "lib" // Literals.node_modules // sub_path in *)
-(* if Sys.file_exists abs_marker *)
-(* then Some abs_marker *)
-(* else None *)
-(* (\* Bs_exception.error (Bs_package_not_found name) *\) *)
-(* with *)
-(* Not_found -> None *)
-(* (\* Bs_exception.error (Bs_package_not_found name) *\) *)
-(* in *)
-(* aux cwd *)
+let rec small_bucket_default eq key default (lst : _ bucketlist) =
+ match lst with
+ | Empty -> default
+ | Cons(k1,d1,rest1) ->
+ if eq key k1 then d1 else
+ match rest1 with
+ | Empty -> default
+ | Cons(k2,d2,rest2) ->
+ if eq key k2 then d2 else
+ match rest2 with
+ | Empty -> default
+ | Cons(k3,d3,rest3) ->
+ if eq key k3 then d3 else
+ small_bucket_default eq key default rest3
end
-module Ext_array : sig
-#1 "ext_array.mli"
+module String_hashtbl : sig
+#1 "string_hashtbl.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -4392,54 +4430,153 @@ module Ext_array : sig
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+include Hashtbl_gen.S with type key = string
-(** Some utilities for {!Array} operations *)
-val reverse_range : 'a array -> int -> int -> unit
-val reverse_in_place : 'a array -> unit
-val reverse : 'a array -> 'a array
-val reverse_of_list : 'a list -> 'a array
+end = struct
+#1 "string_hashtbl.ml"
+# 9 "ext/hashtbl.cppo.ml"
+type key = string
+type 'a t = (key, 'a) Hashtbl_gen.t
+let key_index (h : _ t ) (key : key) =
+ (Bs_hash_stubs.hash_string key ) land (Array.length h.data - 1)
+let eq_key = Ext_string.equal
-val filter : ('a -> bool) -> 'a array -> 'a array
+# 33
+type ('a, 'b) bucketlist = ('a,'b) Hashtbl_gen.bucketlist
+let create = Hashtbl_gen.create
+let clear = Hashtbl_gen.clear
+let reset = Hashtbl_gen.reset
+let copy = Hashtbl_gen.copy
+let iter = Hashtbl_gen.iter
+let fold = Hashtbl_gen.fold
+let length = Hashtbl_gen.length
+let stats = Hashtbl_gen.stats
-val filter_map : ('a -> 'b option) -> 'a array -> 'b array
-val range : int -> int -> int array
-val map2i : (int -> 'a -> 'b -> 'c ) -> 'a array -> 'b array -> 'c array
+let add (h : _ t) key info =
+ let i = key_index h key in
+ let h_data = h.data in
+ Array.unsafe_set h_data i (Cons(key, info, (Array.unsafe_get h_data i)));
+ h.size <- h.size + 1;
+ if h.size > Array.length h_data lsl 1 then Hashtbl_gen.resize key_index h
+
+(* after upgrade to 4.04 we should provide an efficient [replace_or_init] *)
+let modify_or_init (h : _ t) key modf default =
+ let rec find_bucket (bucketlist : _ bucketlist) =
+ match bucketlist with
+ | Cons(k,i,next) ->
+ if eq_key k key then begin modf i; false end
+ else find_bucket next
+ | Empty -> true in
+ let i = key_index h key in
+ let h_data = h.data in
+ if find_bucket (Array.unsafe_get h_data i) then
+ begin
+ Array.unsafe_set h_data i (Cons(key,default (), Array.unsafe_get h_data i));
+ h.size <- h.size + 1 ;
+ if h.size > Array.length h_data lsl 1 then Hashtbl_gen.resize key_index h
+ end
+
+
+let rec remove_bucket key (h : _ t) (bucketlist : _ bucketlist) : _ bucketlist =
+ match bucketlist with
+ | Empty ->
+ Empty
+ | Cons(k, i, next) ->
+ if eq_key k key
+ then begin h.size <- h.size - 1; next end
+ else Cons(k, i, remove_bucket key h next)
+
+let remove (h : _ t ) key =
+ let i = key_index h key in
+ let h_data = h.data in
+ let old_h_szie = h.size in
+ let new_bucket = remove_bucket key h (Array.unsafe_get h_data i) in
+ if old_h_szie <> h.size then
+ Array.unsafe_set h_data i new_bucket
+
+let rec find_rec key (bucketlist : _ bucketlist) = match bucketlist with
+ | Empty ->
+ raise Not_found
+ | Cons(k, d, rest) ->
+ if eq_key key k then d else find_rec key rest
-val to_list_map : ('a -> 'b option) -> 'a array -> 'b list
+let find_exn (h : _ t) key =
+ match Array.unsafe_get h.data (key_index h key) with
+ | Empty -> raise Not_found
+ | Cons(k1, d1, rest1) ->
+ if eq_key key k1 then d1 else
+ match rest1 with
+ | Empty -> raise Not_found
+ | Cons(k2, d2, rest2) ->
+ if eq_key key k2 then d2 else
+ match rest2 with
+ | Empty -> raise Not_found
+ | Cons(k3, d3, rest3) ->
+ if eq_key key k3 then d3 else find_rec key rest3
-val to_list_map_acc :
- ('a -> 'b option) ->
- 'a array ->
- 'b list ->
- 'b list
+let find_opt (h : _ t) key =
+ Hashtbl_gen.small_bucket_opt eq_key key (Array.unsafe_get h.data (key_index h key))
-val of_list_map : ('a -> 'b) -> 'a list -> 'b array
+let find_key_opt (h : _ t) key =
+ Hashtbl_gen.small_bucket_key_opt eq_key key (Array.unsafe_get h.data (key_index h key))
+
+let find_default (h : _ t) key default =
+ Hashtbl_gen.small_bucket_default eq_key key default (Array.unsafe_get h.data (key_index h key))
+let find_all (h : _ t) key =
+ let rec find_in_bucket (bucketlist : _ bucketlist) = match bucketlist with
+ | Empty ->
+ []
+ | Cons(k, d, rest) ->
+ if eq_key k key
+ then d :: find_in_bucket rest
+ else find_in_bucket rest in
+ find_in_bucket (Array.unsafe_get h.data (key_index h key))
-val rfind_with_index : 'a array -> ('a -> 'b -> bool) -> 'b -> int
+let replace h key info =
+ let rec replace_bucket (bucketlist : _ bucketlist) : _ bucketlist = match bucketlist with
+ | Empty ->
+ raise_notrace Not_found
+ | Cons(k, i, next) ->
+ if eq_key k key
+ then Cons(key, info, next)
+ else Cons(k, i, replace_bucket next) in
+ let i = key_index h key in
+ let h_data = h.data in
+ let l = Array.unsafe_get h_data i in
+ try
+ Array.unsafe_set h_data i (replace_bucket l)
+ with Not_found ->
+ begin
+ Array.unsafe_set h_data i (Cons(key, info, l));
+ h.size <- h.size + 1;
+ if h.size > Array.length h_data lsl 1 then Hashtbl_gen.resize key_index h;
+ end
+let mem (h : _ t) key =
+ let rec mem_in_bucket (bucketlist : _ bucketlist) = match bucketlist with
+ | Empty ->
+ false
+ | Cons(k, d, rest) ->
+ eq_key k key || mem_in_bucket rest in
+ mem_in_bucket (Array.unsafe_get h.data (key_index h key))
-type 'a split = [ `No_split | `Split of 'a array * 'a array ]
-val rfind_and_split :
- 'a array ->
- ('a -> 'b -> bool) ->
- 'b -> 'a split
+let of_list2 ks vs =
+ let len = List.length ks in
+ let map = create len in
+ List.iter2 (fun k v -> add map k v) ks vs ;
+ map
-val find_and_split :
- 'a array ->
- ('a -> 'b -> bool) ->
- 'b -> 'a split
-val exists : ('a -> bool) -> 'a array -> bool
+end
+module Bsb_pkg : sig
+#1 "bsb_pkg.mli"
-val is_empty : 'a array -> bool
-end = struct
-#1 "ext_array.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -4465,167 +4602,121 @@ end = struct
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+(** [resolve cwd module_name],
+ [cwd] is current working directory, absolute path
+ Trying to find paths to load [module_name]
+ it is sepcialized for option [-bs-package-include] which requires
+ [npm_package_name/lib/ocaml]
+ it relies on [npm_config_prefix] env variable for global npm modules
+*)
+(** @raise when not found *)
+val resolve_bs_package :
+ cwd:string -> string -> string
-let reverse_range a i len =
- if len = 0 then ()
- else
- for k = 0 to (len-1)/2 do
- let t = Array.unsafe_get a (i+k) in
- Array.unsafe_set a (i+k) ( Array.unsafe_get a (i+len-1-k));
- Array.unsafe_set a (i+len-1-k) t;
- done
-
-
-let reverse_in_place a =
- reverse_range a 0 (Array.length a)
-
-let reverse a =
- let b_len = Array.length a in
- if b_len = 0 then [||] else
- let b = Array.copy a in
- for i = 0 to b_len - 1 do
- Array.unsafe_set b i (Array.unsafe_get a (b_len - 1 -i ))
- done;
- b
-
-let reverse_of_list = function
- | [] -> [||]
- | hd::tl as l ->
- let len = List.length l in
- let a = Array.make len hd in
- let rec fill i = function
- | [] -> a
- | hd::tl -> Array.unsafe_set a (len - i - 2) hd; fill (i+1) tl in
- fill 0 tl
-
-let filter f a =
- let arr_len = Array.length a in
- let rec aux acc i =
- if i = arr_len
- then reverse_of_list acc
- else
- let v = Array.unsafe_get a i in
- if f v then
- aux (v::acc) (i+1)
- else aux acc (i + 1)
- in aux [] 0
-
-
-let filter_map (f : _ -> _ option) a =
- let arr_len = Array.length a in
- let rec aux acc i =
- if i = arr_len
- then reverse_of_list acc
- else
- let v = Array.unsafe_get a i in
- match f v with
- | Some v ->
- aux (v::acc) (i+1)
- | None ->
- aux acc (i + 1)
- in aux [] 0
-
-let range from to_ =
- if from > to_ then invalid_arg "Ext_array.range"
- else Array.init (to_ - from + 1) (fun i -> i + from)
-let map2i f a b =
- let len = Array.length a in
- if len <> Array.length b then
- invalid_arg "Ext_array.map2i"
- else
- Array.mapi (fun i a -> f i a ( Array.unsafe_get b i )) a
+end = struct
+#1 "bsb_pkg.ml"
- let rec tolist_aux a f i res =
- if i < 0 then res else
- let v = Array.unsafe_get a i in
- tolist_aux a f (i - 1)
- (match f v with
- | Some v -> v :: res
- | None -> res)
+let (//) = Filename.concat
-let to_list_map f a =
- tolist_aux a f (Array.length a - 1) []
-let to_list_map_acc f a acc =
- tolist_aux a f (Array.length a - 1) acc
-(* TODO: What would happen if [f] raise, memory leak? *)
-let of_list_map f a =
- match a with
- | [] -> [||]
- | h::tl ->
- let hd = f h in
- let len = List.length tl + 1 in
- let arr = Array.make len hd in
- let rec fill i = function
- | [] -> arr
- | hd :: tl ->
- Array.unsafe_set arr i (f hd);
- fill (i + 1) tl in
- fill 1 tl
-
-(**
-{[
-# rfind_with_index [|1;2;3|] (=) 2;;
-- : int = 1
-# rfind_with_index [|1;2;3|] (=) 1;;
-- : int = 0
-# rfind_with_index [|1;2;3|] (=) 3;;
-- : int = 2
-# rfind_with_index [|1;2;3|] (=) 4;;
-- : int = -1
-]}
+(** It makes sense to have this function raise, when [bsb] could not resolve a package, it used to mean
+ a failure
*)
-let rfind_with_index arr cmp v =
- let len = Array.length arr in
- let rec aux i =
- if i < 0 then i
- else if cmp (Array.unsafe_get arr i) v then i
- else aux (i - 1) in
- aux (len - 1)
-
-type 'a split = [ `No_split | `Split of 'a array * 'a array ]
-let rfind_and_split arr cmp v : _ split =
- let i = rfind_with_index arr cmp v in
- if i < 0 then
- `No_split
- else
- `Split (Array.sub arr 0 i , Array.sub arr (i + 1 ) (Array.length arr - i - 1 ))
-
-
-let find_with_index arr cmp v =
- let len = Array.length arr in
- let rec aux i len =
- if i >= len then -1
- else if cmp (Array.unsafe_get arr i ) v then i
- else aux (i + 1) len in
- aux 0 len
+let resolve_bs_package
+ ~cwd
+ name =
+ let marker = Literals.bsconfig_json in
+ let sub_path = name // marker in
+ let rec aux cwd =
+ let abs_marker = cwd // Literals.node_modules // sub_path in
+ if Sys.file_exists abs_marker then (* Some *) (Filename.dirname abs_marker)
+ else
+ let cwd' = Filename.dirname cwd in (* TODO: may non-terminating when see symlinks *)
+ if String.length cwd' < String.length cwd then
+ aux cwd'
+ else
+ try
+ let abs_marker =
+ Sys.getenv "npm_config_prefix"
+ // "lib" // Literals.node_modules // sub_path in
+ if Sys.file_exists abs_marker
+ then
+ Filename.dirname abs_marker
+ else
+ begin
+ Format.fprintf Format.err_formatter
+ "@{Package not found: resolving package %s in %s @}@." name cwd ;
+ Bsb_exception.error (Package_not_found (name, None))
+ end
+ with
+ Not_found ->
+ begin
+ Format.fprintf Format.err_formatter
+ "@{Package not found: resolving package %s in %s @}@." name cwd ;
+ Bsb_exception.error (Package_not_found (name,None))
+ end
+ in
+ aux cwd
-let find_and_split arr cmp v : _ split =
- let i = find_with_index arr cmp v in
- if i < 0 then
- `No_split
- else
- `Split (Array.sub arr 0 i, Array.sub arr (i + 1 ) (Array.length arr - i - 1))
-(** TODO: available since 4.03, use {!Array.exists} *)
+let cache = String_hashtbl.create 0
-let exists p a =
- let n = Array.length a in
- let rec loop i =
- if i = n then false
- else if p (Array.unsafe_get a i) then true
- else loop (succ i) in
- loop 0
+(** TODO: collect all warnings and print later *)
+let resolve_bs_package ~cwd package =
+ match String_hashtbl.find_opt cache package with
+ | None ->
+ let result = resolve_bs_package ~cwd package in
+ Format.fprintf Format.std_formatter "@{Package@} %s -> %s@." package result ;
+ String_hashtbl.add cache package result ;
+ result
+ | Some x
+ ->
+ let result = resolve_bs_package ~cwd package in
+ if result <> x then
+ begin
+ Format.fprintf Format.err_formatter
+ "@{Duplicated package:@} %s %s (chosen) vs %s in %s @." package x result cwd;
+ end;
+ x
+(** The package does not need to be a bspackage
+ example:
+ {[
+ resolve_npm_package_file ~cwd "reason/refmt";;
+ resolve_npm_package_file ~cwd "reason/refmt/xx/yy"
+ ]}
+ It also returns the path name
+ Note the input [sub_path] is already converted to physical meaning path according to OS
+*)
+(* let resolve_npm_package_file ~cwd sub_path = *)
+(* let rec aux cwd = *)
+(* let abs_marker = cwd // Literals.node_modules // sub_path in *)
+(* if Sys.file_exists abs_marker then Some abs_marker *)
+(* else *)
+(* let cwd' = Filename.dirname cwd in *)
+(* if String.length cwd' < String.length cwd then *)
+(* aux cwd' *)
+(* else *)
+(* try *)
+(* let abs_marker = *)
+(* Sys.getenv "npm_config_prefix" *)
+(* // "lib" // Literals.node_modules // sub_path in *)
+(* if Sys.file_exists abs_marker *)
+(* then Some abs_marker *)
+(* else None *)
+(* (\* Bs_exception.error (Bs_package_not_found name) *\) *)
+(* with *)
+(* Not_found -> None *)
+(* (\* Bs_exception.error (Bs_package_not_found name) *\) *)
+(* in *)
+(* aux cwd *)
-let is_empty arr =
- Array.length arr = 0
end
module Ext_json_parse : sig
#1 "ext_json_parse.mli"
@@ -6377,7 +6468,6 @@ type module_info =
{
mli : mli_kind ;
ml : ml_kind ;
- mll : string option
}
type file_group_rouces = module_info String_map.t
@@ -6445,7 +6535,7 @@ type module_info =
{
mli : mli_kind ;
ml : ml_kind ;
- mll : string option ;
+ (*mll : string option ;*)
}
@@ -6460,7 +6550,7 @@ let module_info_magic_number = "BSBUILD20161019"
let dir_of_module_info (x : module_info)
=
match x with
- | { mli; ml; mll} ->
+ | { mli; ml; } ->
begin match mli with
| Mli s | Rei s ->
Filename.dirname s
@@ -6468,11 +6558,11 @@ let dir_of_module_info (x : module_info)
begin match ml with
| Ml s | Re s ->
Filename.dirname s
- | Ml_empty ->
- begin match mll with
+ | Ml_empty -> Ext_string.empty
+ (*begin match mll with
| None -> ""
| Some s -> Filename.dirname s
- end
+ end *)
end
end
@@ -6494,7 +6584,7 @@ let read_build_cache bsbuild : t =
let bsbuild_cache = ".bsbuild"
-let empty_module_info = {mli = Mli_empty ; mll = None ; ml = Ml_empty}
+let empty_module_info = {mli = Mli_empty ; ml = Ml_empty}
let adjust_module_info x suffix name =
match suffix with
@@ -6502,7 +6592,6 @@ let adjust_module_info x suffix name =
| ".re" -> {x with ml = Re name}
| ".mli" -> {x with mli = Mli name}
| ".rei" -> { x with mli = Rei name}
- | ".mll" -> {x with mll = Some name}
| _ -> failwith ("don't know what to do with " ^ name)
let map_update ?dir (map : file_group_rouces) name : file_group_rouces =
@@ -7401,7 +7490,7 @@ type file_group =
type t =
- { files : file_group list ;
+ { files : file_group list ; (* flattened list of directories *)
intervals : Ext_file_pp.interval list ;
globbed_dirs : string list ;
@@ -7415,7 +7504,8 @@ type parsing_cxt = {
no_dev : bool ;
dir_index : dir_index ;
cwd : string ;
- root : string
+ root : string ;
+ cut_generators : bool
}
@@ -7547,7 +7637,8 @@ type parsing_cxt = {
no_dev : bool ;
dir_index : dir_index ;
cwd : string ;
- root : string
+ root : string;
+ cut_generators : bool
}
let handle_list_files acc
@@ -7593,6 +7684,29 @@ let (++) (u : t) (v : t) =
globbed_dirs = u.globbed_dirs @ v.globbed_dirs ;
}
+let get_input_output loc_start (content : Ext_json_types.t array) =
+ let error () =
+ Bsb_exception.failf ~loc:loc_start {| invalid edge format, expect ["input" , ":", "output" ]|}
+ in
+ match Ext_array.find_and_split content
+ (fun x () -> match x with Str { str =":"} -> true | _ -> false )
+ () with
+ | `No_split -> error ()
+ | `Split ( output, input) ->
+ Ext_array.to_list_map (fun (x : Ext_json_types.t) ->
+ match x with
+ | Str {str = ":"} ->
+ error ()
+ | Str {str } ->
+ Some str
+ | _ -> None) output ,
+ Ext_array.to_list_map (fun (x : Ext_json_types.t) ->
+ match x with
+ | Str {str = ":"} ->
+ error ()
+ | Str {str} ->
+ Some str (* More rigirous error checking: It would trigger a ninja syntax error *)
+ | _ -> None) input
(** [dir_index] can be inherited *)
let rec
@@ -7632,7 +7746,7 @@ and parsing_source ({no_dev; dir_index ; cwd} as cxt ) (x : Ext_json_types.t )
| _ -> empty
and parsing_source_dir_map
- ({ cwd = dir} as cxt )
+ ({ cwd = dir; no_dev; cut_generators } as cxt )
(x : Ext_json_types.t String_map.t)
(* { dir : xx, files : ... } [dir] is already extracted *)
=
@@ -7642,36 +7756,42 @@ and parsing_source_dir_map
let cur_update_queue = ref [] in
let cur_globbed_dirs = ref [] in
let generators : build_generator list ref = ref [] in
- (* begin match String_map.find_opt Bsb_build_schemas.generators x with *)
- (* | Some (Arr { content }) -> *)
- (* (\* TODO: need check is dev build or not *\) *)
- (* content |> Array.iter (fun (x : Ext_json_types.t) -> *)
- (* match x with *)
- (* | Obj { map = generator; loc} -> *)
- (* begin match String_map.find_opt Bsb_build_schemas.input generator, *)
- (* String_map.find_opt Bsb_build_schemas.output generator, *)
- (* String_map.find_opt Bsb_build_schemas.cmd generator *)
- (* with *)
- (* | Some (Str{str = input}), Some (Str {str = output}), Some (Str {str = cmd})-> *)
- (* generators := {input ; output ; cmd } :: !generators; *)
- (* (\** Now adding source files, it may be re-added again later when scanning files *)
- (* *\) *)
- (* begin match Ext_string.is_valid_source_name output with *)
- (* | Good -> *)
- (* cur_sources := Binary_cache.map_update ~dir !cur_sources output *)
- (* | Invalid_module_name -> *)
- (* () *)
- (* (\*Format.fprintf Format.err_formatter warning_unused_file output dir *\) *)
- (* | Suffix_mismatch -> () *)
- (* end *)
- (* | _ -> *)
- (* Bsb_exception.failf ~loc "Invalid generator format" *)
- (* end *)
- (* | _ -> () *)
- (* ) *)
- (* | Some _ | None -> () *)
- (* end *)
- (* ; *)
+ begin match String_map.find_opt Bsb_build_schemas.generators x with
+ | Some (Arr { content ; loc_start}) ->
+ (* Need check is dev build or not *)
+ content
+ |> Array.iter (fun (x : Ext_json_types.t) ->
+ match x with
+ | Obj { map = generator; loc} ->
+ begin match String_map.find_opt Bsb_build_schemas.name generator,
+ String_map.find_opt Bsb_build_schemas.edge generator
+ with
+ | Some (Str{str = command}), Some (Arr {content })->
+
+ let output, input = get_input_output loc_start content in
+ if not cut_generators && not no_dev then begin
+ generators := {input ; output ; command } :: !generators
+ end;
+ (** Now adding source files, it may be re-added again later when scanning files *)
+ output |> List.iter begin fun output ->
+ begin match Ext_string.is_valid_source_name output with
+ | Good ->
+ cur_sources := Binary_cache.map_update ~dir !cur_sources output
+ | Invalid_module_name ->
+ ()
+ (*Format.fprintf Format.err_formatter warning_unused_file output dir *)
+ | Suffix_mismatch -> ()
+ end
+ end
+ | _ ->
+ Bsb_exception.failf ~loc "Invalid generator format"
+ end
+ | _ -> Bsb_exception.failf ~loc:(Ext_json.loc_of x) "Invalid generator format"
+ )
+ | Some x -> Bsb_exception.failf ~loc:(Ext_json.loc_of x ) "Invalid generators format"
+ | None -> ()
+ end
+ ;
begin match String_map.find_opt Bsb_build_schemas.files x with
| Some (Arr {loc_start;loc_end; content = [||] }) -> (* [ ] *)
let tasks, files = handle_list_files !cur_sources cxt loc_start loc_end in
@@ -8142,6 +8262,8 @@ type t =
generate_merlin : bool ;
reason_react_jsx : bool ; (* whether apply PPX transform or not*)
entries : entries_t list ;
+ generators : string String_map.t ;
+ cut_generators : bool; (* note when used as a dev mode, we will always ignore it *)
}
end
@@ -8575,6 +8697,7 @@ let interpret_json
let js_post_build_cmd = ref None in
let built_in_package = ref None in
let generate_merlin = ref true in
+ let generators = ref String_map.empty in
let package_specs = ref (String_set.singleton Literals.commonjs) in
(* When we plan to add more deps here,
Make sure check it is consistent that for nested deps, we have a
@@ -8588,7 +8711,7 @@ let interpret_json
2. we need store it so that we can call ninja correctly
*)
let entries = ref Bsb_default.main_entries in
-
+ let cut_generators = ref false in
let config_json_chan = open_in_bin config_json in
let global_data = Ext_json_parse.parse_json_from_chan config_json_chan in
match global_data with
@@ -8642,6 +8765,20 @@ let interpret_json
else Bsb_build_util.resolve_bsb_magic_file ~cwd ~desc:Bsb_build_schemas.ppx_flags p
)
))
+ |? (Bsb_build_schemas.cut_generators, `Bool (fun b -> cut_generators := b))
+ |? (Bsb_build_schemas.generators, `Arr (fun s ->
+ generators :=
+ Array.fold_left (fun acc json ->
+ match (json : Ext_json_types.t) with
+ | Obj {map = m ; loc} ->
+ begin match String_map.find_opt Bsb_build_schemas.name m,
+ String_map.find_opt Bsb_build_schemas.command m with
+ | Some (Str {str = name}), Some ( Str {str = command}) ->
+ String_map.add name command acc
+ | _, _ ->
+ Bsb_exception.failf ~loc {| generators exepect format like { "name" : "cppo", "command" : "cppo $in -o $out"} |}
+ end
+ | _ -> acc ) String_map.empty s ))
|? (Bsb_build_schemas.refmt, `Str (fun s ->
refmt := Some (Bsb_build_util.resolve_bsb_magic_file ~cwd ~desc:Bsb_build_schemas.refmt s) ))
|? (Bsb_build_schemas.refmt_flags, `Arr (fun s -> refmt_flags := get_list_string s))
@@ -8649,8 +8786,11 @@ let interpret_json
|> ignore ;
begin match String_map.find_opt Bsb_build_schemas.sources map with
| Some x ->
- let res = Bsb_build_ui.parsing_sources {no_dev; dir_index =
- Bsb_build_ui.lib_dir_index; cwd = Filename.current_dir_name; root = cwd} x in
+ let res = Bsb_build_ui.parsing_sources
+ {no_dev;
+ dir_index =
+ Bsb_build_ui.lib_dir_index; cwd = Filename.current_dir_name;
+ root = cwd; cut_generators = !cut_generators} x in
if generate_watch_metadata then
generate_sourcedirs_meta cwd res ;
begin match List.sort Ext_file_pp.interval_compare res.intervals with
@@ -8694,7 +8834,9 @@ let interpret_json
built_in_dependency = !built_in_package;
generate_merlin = !generate_merlin ;
reason_react_jsx = !reason_react_jsx ;
- entries = !entries
+ entries = !entries;
+ generators = !generators ;
+ cut_generators = !cut_generators
}
| None -> failwith "no sources specified, please checkout the schema for more details"
end
@@ -8983,14 +9125,8 @@ module Bsb_rule : sig
type t
-val get_name : t -> out_channel -> string
-val define :
- command:string ->
- ?depfile:string ->
- ?restat:unit ->
- ?description:string ->
- string -> t
+val get_name : t -> out_channel -> string
val build_ast_and_deps : t
val build_ast_and_deps_from_reason_impl : t
@@ -9003,7 +9139,18 @@ val build_cmj_js : t
val build_cmj_cmi_js : t
val build_cmi : t
-val reset : unit -> unit
+
+(** rules are generally composed of built-in rules and customized rules, there are two design choices:
+ 1. respect custom rules with the same name, then we need adjust our built-in
+ rules dynamically in case the conflict.
+ 2. respect our built-in rules, then we only need re-load custom rules for each bsconfig.json
+*)
+
+
+(** Since now we generate ninja files per bsconfig.json in a single process,
+ we must make sure it is re-entrant
+*)
+val reset : string String_map.t -> t String_map.t
end = struct
#1 "bsb_rule.ml"
@@ -9070,6 +9217,7 @@ let print_rule oc ~description ?restat ?depfile ~command name =
output_string oc " description = " ; output_string oc description; output_string oc "\n"
+(** allocate an unique name for such rule*)
let define
~command
?depfile
@@ -9077,19 +9225,23 @@ let define
?(description = "\027[34mBuilding\027[39m \027[2m${out}\027[22m") (* blue, dim *)
name
=
+ let rule_name = ask_name name in
let rec self = {
used = false;
- rule_name = ask_name name ;
+ rule_name ;
name = fun oc ->
if not self.used then
begin
- print_rule oc ~description ?depfile ?restat ~command name;
+ print_rule oc ~description ?depfile ?restat ~command rule_name;
self.used <- true
end ;
- self.rule_name
+ rule_name
} in self
+
+
+
let build_ast_and_deps =
define
~command:"${bsc} ${pp_flags} ${ppx_flags} ${bsc_flags} -c -o ${out} -bs-syntax-only -bs-binary-ast ${in}"
@@ -9174,20 +9326,30 @@ let build_cmi =
~depfile:"${in}.d"
"build_cmi" (* the compiler should always consult [.cmi], current the vanilla ocaml compiler only consult [.cmi] when [.mli] found*)
-let reset () =
- rule_id := 0;
- rule_names := String_set.empty;
- build_ast_and_deps.used <- false ;
- build_ast_and_deps_from_reason_impl.used <- false ;
- build_ast_and_deps_from_reason_intf.used <- false ;
- build_bin_deps.used <- false;
- reload.used <- false;
- copy_resources.used <- false ;
- build_ml_from_mll.used <- false ;
- build_cmj_js.used <- false;
- build_cmj_cmi_js.used <- false ;
- build_cmi.used <- false
+(* a snapshot of rule_names environment*)
+let built_in_rule_names = !rule_names
+let built_in_rule_id = !rule_id
+
+let reset (custom_rules : string String_map.t) =
+ begin
+ rule_id := built_in_rule_id;
+ rule_names := built_in_rule_names;
+
+ build_ast_and_deps.used <- false ;
+ build_ast_and_deps_from_reason_impl.used <- false ;
+ build_ast_and_deps_from_reason_intf.used <- false ;
+ build_bin_deps.used <- false;
+ reload.used <- false;
+ copy_resources.used <- false ;
+ build_ml_from_mll.used <- false ;
+ build_cmj_js.used <- false;
+ build_cmj_cmi_js.used <- false ;
+ build_cmi.used <- false ;
+ String_map.mapi (fun name command ->
+ define ~command name
+ ) custom_rules
+ end
end
@@ -9257,6 +9419,7 @@ val handle_file_groups : out_channel ->
package_specs:Bsb_config.package_specs ->
js_post_build_cmd:string option ->
files_to_install:String_hash_set.t ->
+ custom_rules:Bsb_rule.t String_map.t ->
Bsb_build_ui.file_group list ->
info -> info
@@ -9423,7 +9586,8 @@ let (++) (us : info) (vs : info) =
let install_file (file : string) files_to_install =
String_hash_set.add files_to_install (Ext_filename.chop_extension_if_any file )
-let handle_file_group oc ~package_specs ~js_post_build_cmd
+let handle_file_group oc ~custom_rules
+ ~package_specs ~js_post_build_cmd
(files_to_install : String_hash_set.t) acc (group: Bsb_build_ui.file_group) : info =
let handle_module_info oc module_name
( module_info : Binary_cache.module_info)
@@ -9433,11 +9597,11 @@ let handle_file_group oc ~package_specs ~js_post_build_cmd
| Export_all -> true
| Export_none -> false
| Export_set set -> String_set.mem module_name set in
- let emit_build (kind : [`Ml | `Mll | `Re | `Mli | `Rei ]) file_input : info =
+ let emit_build (kind : [`Ml | `Re | `Mli | `Rei ]) file_input : info =
let filename_sans_extension = Filename.chop_extension file_input in
let input = Bsb_config.proj_rel file_input in
let output_file_sans_extension = filename_sans_extension in
- let output_ml = output_file_sans_extension ^ Literals.suffix_ml in
+ (*let output_ml = output_file_sans_extension ^ Literals.suffix_ml in*)
let output_mlast = output_file_sans_extension ^ Literals.suffix_mlast in
let output_mlastd = output_file_sans_extension ^ Literals.suffix_mlastd in
let output_mliast = output_file_sans_extension ^ Literals.suffix_mliast in
@@ -9471,20 +9635,20 @@ let handle_file_group oc ~package_specs ~js_post_build_cmd
]
)
in
- if kind = `Mll then
+ (*if kind = `Mll then
output_build oc
~output:output_ml
~input
- ~rule: Rules.build_ml_from_mll ;
+ ~rule: Rules.build_ml_from_mll ;*)
begin match kind with
- | `Mll
+ (*| `Mll*)
| `Ml
| `Re ->
let input, rule =
if kind = `Re then
input, Rules.build_ast_and_deps_from_reason_impl
- else if kind = `Mll then
- output_ml, Rules.build_ast_and_deps
+ (*else if kind = `Mll then
+ output_ml, Rules.build_ast_and_deps*)
else
input, Rules.build_ast_and_deps
in
@@ -9572,25 +9736,29 @@ let handle_file_group oc ~package_specs ~js_post_build_cmd
emit_build `Rei rei_file
| Mli_empty -> zero
end ++
- begin match module_info.mll with
- | Some mll_file ->
- begin match module_info.ml with
- | Ml_empty -> emit_build `Mll mll_file
- | Ml input | Re input ->
- failwith ("both "^ mll_file ^ " and " ^ input ^ " are found in source listings" )
- end
- | None -> zero
- end ++ info
+ info
in
- (*
+ let map_to_source_dir =
+ (fun x -> Bsb_config.proj_rel (group.dir //x )) in
group.generators
- |> List.iter (fun ({output; input; cmd} : Bsb_build_ui.generator)->
- output_build oc ~output:(Bsb_config.proj_rel output)
- ~input:(Bsb_config.proj_rel input)
- ~rule:cmd
- );
- *) (* we need create a rule for it --
+ |> List.iter (fun ({output; input; command} : Bsb_build_ui.build_generator)->
+ begin match String_map.find_opt command custom_rules with
+ | None -> Ext_pervasives.failwithf ~loc:__LOC__ "custom rule %s used but not defined" command
+ | Some rule ->
+ begin match output, input with
+ | output::outputs, input::inputs ->
+ output_build oc
+ ~outputs:(List.map map_to_source_dir outputs)
+ ~inputs:(List.map map_to_source_dir inputs)
+ ~output:(map_to_source_dir output)
+ ~input:(map_to_source_dir input)
+ ~rule
+ | [], _ (* either output or input can not be empty *)
+ | _, [] -> assert false (* Error should be raised earlier *)
+ end
+ end
+ ); (* we need create a rule for it --
{[
rule ocamllex
]}
@@ -9604,9 +9772,9 @@ let handle_file_group oc ~package_specs ~js_post_build_cmd
let handle_file_groups
oc ~package_specs ~js_post_build_cmd
- ~files_to_install
+ ~files_to_install ~custom_rules
(file_groups : Bsb_build_ui.file_group list) st =
- List.fold_left (handle_file_group oc ~package_specs ~js_post_build_cmd files_to_install ) st file_groups
+ List.fold_left (handle_file_group oc ~package_specs ~custom_rules ~js_post_build_cmd files_to_install ) st file_groups
end
module Bsb_gen : sig
@@ -9694,30 +9862,29 @@ let dash_i = "-I"
let refmt_exe = "refmt.exe"
let dash_ppx = "-ppx"
-let ninja_required_version = "ninja_required_version = 1.5.1 \n"
-
let output_ninja
~cwd
~bsc_dir
- {
- Bsb_config_types.package_name;
- ocamllex;
- external_includes;
- bsc_flags ;
- ppx_flags;
- bs_dependencies;
- bs_dev_dependencies;
- refmt;
- refmt_flags;
- js_post_build_cmd;
- package_specs;
- bs_file_groups;
- files_to_install;
- built_in_dependency;
- reason_react_jsx
- }
+ ({
+ package_name;
+ ocamllex;
+ external_includes;
+ bsc_flags ;
+ ppx_flags;
+ bs_dependencies;
+ bs_dev_dependencies;
+ refmt;
+ refmt_flags;
+ js_post_build_cmd;
+ package_specs;
+ bs_file_groups;
+ files_to_install;
+ built_in_dependency;
+ reason_react_jsx;
+ generators ;
+ } : Bsb_config_types.t)
=
- let () = Bsb_rule.reset () in
+ let custom_rules = Bsb_rule.reset generators in
let bsc = bsc_dir // bsc_exe in (* The path to [bsc.exe] independent of config *)
let bsdep = bsc_dir // bsb_helper_exe in (* The path to [bsb_heler.exe] *)
(* let builddir = Bsb_config.lib_bs in *)
@@ -9727,7 +9894,6 @@ let output_ninja
let oc = open_out_bin (cwd // Bsb_config.lib_bs // Literals.build_ninja) in
begin
let () =
- output_string oc ninja_required_version ;
output_string oc "bs_package_flags = ";
output_string oc ("-bs-package-name " ^ package_name);
output_string oc "\n";
@@ -9805,7 +9971,8 @@ let output_ninja
static_resources;
in
let all_info =
- Bsb_ninja.handle_file_groups oc
+ Bsb_ninja.handle_file_groups oc
+ ~custom_rules
~js_post_build_cmd ~package_specs ~files_to_install bs_file_groups Bsb_ninja.zero in
let () =
List.iter (fun x -> Bsb_ninja.output_build oc
@@ -9900,32 +10067,51 @@ let root = OCamlRes.Res.([
"\n\
\n\
let () = Js.log \"Hello, BuckleScript\"")]) ;
- File (".gitignore",
- "*.exe\n\
- *.obj\n\
- *.out\n\
- *.compile\n\
- *.native\n\
- *.byte\n\
- *.cmo\n\
- *.annot\n\
- *.cmi\n\
- *.cmx\n\
- *.cmt\n\
- *.cmti\n\
- *.cma\n\
- *.a\n\
- *.cmxa\n\
- *.obj\n\
- *~\n\
- *.annot\n\
- *.cmj\n\
- *.bak\n\
- lib/bs\n\
- *.mlast\n\
- *.mliast\n\
- .vscode\n\
- .merlin") ;
+ File ("README.md",
+ "\n\
+ \n\
+ # Build\n\
+ ```\n\
+ npm run build\n\
+ ```\n\
+ \n\
+ # Watch\n\
+ \n\
+ ```\n\
+ npm run watch\n\
+ ```\n\
+ \n\
+ \n\
+ # Editor\n\
+ If you use `vscode`, Press `Windows + Shift + B` it will build automatically") ;
+ File ("package.json",
+ "{\n\
+ \ \"name\": \"${bsb:name}\",\n\
+ \ \"version\": \"${bsb:proj-version}\",\n\
+ \ \"scripts\": {\n\
+ \ \"clean\": \"bsb -clean-world\",\n\
+ \ \"build\": \"bsb -make-world\",\n\
+ \ \"watch\": \"bsb -make-world -w\"\n\
+ \ },\n\
+ \ \"keywords\": [\n\
+ \ \"BuckleScript\"\n\
+ \ ],\n\
+ \ \"license\": \"MIT\",\n\
+ \ \"devDependencies\": {\n\
+ \ \"bs-platform\": \"${bsb:bs-version}\"\n\
+ \ }\n\
+ }") ;
+ File ("bsconfig.json",
+ "{\n\
+ \ \"name\": \"${bsb:name}\",\n\
+ \ \"version\": \"${bsb:proj-version}\",\n\
+ \ \"sources\": [\n\
+ \ \"src\"\n\
+ \ ],\n\
+ \ \"bs-dependencies\" : [\n\
+ \ // add your bs-dependencies here \n\
+ \ ]\n\
+ }") ;
Dir (".vscode", [
File ("tasks.json",
"{\n\
@@ -9966,58 +10152,37 @@ let root = OCamlRes.Res.([
\ ]\n\
\ }\n\
}")]) ;
- File ("package.json",
- "{\n\
- \ \"name\": \"${bsb:name}\",\n\
- \ \"version\": \"${bsb:proj-version}\",\n\
- \ \"scripts\": {\n\
- \ \"clean\": \"bsb -clean-world\",\n\
- \ \"build\": \"bsb -make-world\",\n\
- \ \"watch\": \"bsb -make-world -w\"\n\
- \ },\n\
- \ \"keywords\": [\n\
- \ \"BuckleScript\"\n\
- \ ],\n\
- \ \"license\": \"MIT\",\n\
- \ \"devDependencies\": {\n\
- \ \"bs-platform\": \"${bsb:bs-version}\"\n\
- \ }\n\
- }") ;
- File ("bsconfig.json",
- "{\n\
- \ \"name\": \"${bsb:name}\",\n\
- \ \"version\": \"${bsb:proj-version}\",\n\
- \ \"sources\": [\n\
- \ \"src\"\n\
- \ ],\n\
- \ \"bs-dependencies\" : [\n\
- \ // add your bs-dependencies here \n\
- \ ]\n\
- }") ;
- File ("README.md",
- "\n\
- \n\
- # Build\n\
- ```\n\
- npm run build\n\
- ```\n\
- \n\
- # Watch\n\
- \n\
- ```\n\
- npm run watch\n\
- ```\n\
- \n\
- \n\
- # Editor\n\
- If you use `vscode`, Press `Windows + Shift + B` it will build automatically")]) ;
+ File (".gitignore",
+ "*.exe\n\
+ *.obj\n\
+ *.out\n\
+ *.compile\n\
+ *.native\n\
+ *.byte\n\
+ *.cmo\n\
+ *.annot\n\
+ *.cmi\n\
+ *.cmx\n\
+ *.cmt\n\
+ *.cmti\n\
+ *.cma\n\
+ *.a\n\
+ *.cmxa\n\
+ *.obj\n\
+ *~\n\
+ *.annot\n\
+ *.cmj\n\
+ *.bak\n\
+ lib/bs\n\
+ *.mlast\n\
+ *.mliast\n\
+ .vscode\n\
+ .merlin")]) ;
Dir ("minimal", [
Dir ("src", [ File ("main.ml", "")]) ;
- File (".gitignore",
- "lib\n\
- node_modules\n\
- .merlin\n\
- npm-debug.log") ;
+ File ("README.md",
+ "\n\
+ \ # ${bsb:name}") ;
File ("package.json",
"{\n\
\ \"name\": \"${bsb:name}\",\n\
@@ -10040,9 +10205,11 @@ let root = OCamlRes.Res.([
\ \"name\": \"${bsb:name}\",\n\
\ \"sources\": [\"src\"]\n\
}") ;
- File ("README.md",
- "\n\
- \ # ${bsb:name}")])
+ File (".gitignore",
+ "lib\n\
+ node_modules\n\
+ .merlin\n\
+ npm-debug.log")])
])
end
diff --git a/jscomp/bin/bsb_helper.ml b/jscomp/bin/bsb_helper.ml
index 792f83804b..3ae670f123 100644
--- a/jscomp/bin/bsb_helper.ml
+++ b/jscomp/bin/bsb_helper.ml
@@ -654,7 +654,8 @@ let is_valid_source_name name : check_result =
match check_any_suffix_case_then_chop name [
".ml";
".re";
- ".mli"; ".mll"; ".rei"
+ ".mli";
+ ".rei"
] with
| None -> Suffix_mismatch
| Some x ->
@@ -4017,7 +4018,6 @@ type module_info =
{
mli : mli_kind ;
ml : ml_kind ;
- mll : string option
}
type file_group_rouces = module_info String_map.t
@@ -4085,7 +4085,7 @@ type module_info =
{
mli : mli_kind ;
ml : ml_kind ;
- mll : string option ;
+ (*mll : string option ;*)
}
@@ -4100,7 +4100,7 @@ let module_info_magic_number = "BSBUILD20161019"
let dir_of_module_info (x : module_info)
=
match x with
- | { mli; ml; mll} ->
+ | { mli; ml; } ->
begin match mli with
| Mli s | Rei s ->
Filename.dirname s
@@ -4108,11 +4108,11 @@ let dir_of_module_info (x : module_info)
begin match ml with
| Ml s | Re s ->
Filename.dirname s
- | Ml_empty ->
- begin match mll with
+ | Ml_empty -> Ext_string.empty
+ (*begin match mll with
| None -> ""
| Some s -> Filename.dirname s
- end
+ end *)
end
end
@@ -4134,7 +4134,7 @@ let read_build_cache bsbuild : t =
let bsbuild_cache = ".bsbuild"
-let empty_module_info = {mli = Mli_empty ; mll = None ; ml = Ml_empty}
+let empty_module_info = {mli = Mli_empty ; ml = Ml_empty}
let adjust_module_info x suffix name =
match suffix with
@@ -4142,7 +4142,6 @@ let adjust_module_info x suffix name =
| ".re" -> {x with ml = Re name}
| ".mli" -> {x with mli = Mli name}
| ".rei" -> { x with mli = Rei name}
- | ".mll" -> {x with mll = Some name}
| _ -> failwith ("don't know what to do with " ^ name)
let map_update ?dir (map : file_group_rouces) name : file_group_rouces =
@@ -4266,7 +4265,7 @@ let handle_bin_depfile
Array.fold_left
(fun ((acc, len) as v) k ->
match String_map.find_opt k data.(0) with
- | Some ({ml = Ml s | Re s } | {mll = Some s })
+ | Some {ml = Ml s | Re s }
->
let new_file = op_concat @@ Filename.chop_extension s ^ suffix_inteface
in (new_file :: acc , len + String.length new_file + length_space)
@@ -4278,7 +4277,7 @@ let handle_bin_depfile
if index = 0 then v
else
begin match String_map.find_opt k data.(index) with
- | Some ({ml = Ml s | Re s } | {mll = Some s })
+ | Some {ml = Ml s | Re s }
->
let new_file = op_concat @@ Filename.chop_extension s ^ suffix_inteface
in (new_file :: acc , len + String.length new_file + length_space)
@@ -4306,7 +4305,6 @@ let handle_bin_depfile
(fun ((acc, len) as v) k ->
match String_map.find_opt k data.(0) with
| Some ({ ml = Ml f | Re f }
- | { mll = Some f }
| { mli = Mli f | Rei f }) ->
let new_file = (op_concat @@ Filename.chop_extension f ^ Literals.suffix_cmi) in
(new_file :: acc , len + String.length new_file + length_space)
@@ -4316,7 +4314,6 @@ let handle_bin_depfile
else
begin match String_map.find_opt k data.(index) with
| Some ({ ml = Ml f | Re f }
- | { mll = Some f }
| { mli = Mli f | Rei f }) ->
let new_file = (op_concat @@ Filename.chop_extension f ^ Literals.suffix_cmi) in
(new_file :: acc , len + String.length new_file + length_space)
diff --git a/jscomp/bin/bsb_watcher.js b/jscomp/bin/bsb_watcher.js
index 7ffa63ab5d..47cd693345 100644
--- a/jscomp/bin/bsb_watcher.js
+++ b/jscomp/bin/bsb_watcher.js
@@ -106,7 +106,7 @@ function build() {
*/
function on_change(event, reason) {
if(validEvent(event,reason)){
- console.log("Event", event);
+ console.log("Event", event, reason);
reasons_to_rebuild.push([event, reason])
if(needRebuild()){
build()
diff --git a/jscomp/bin/bsdep.ml b/jscomp/bin/bsdep.ml
index 5bc6bca6ac..e8a6c9f21a 100644
--- a/jscomp/bin/bsdep.ml
+++ b/jscomp/bin/bsdep.ml
@@ -23680,7 +23680,8 @@ let is_valid_source_name name : check_result =
match check_any_suffix_case_then_chop name [
".ml";
".re";
- ".mli"; ".mll"; ".rei"
+ ".mli";
+ ".rei"
] with
| None -> Suffix_mismatch
| Some x ->
@@ -28858,6 +28859,12 @@ val find_and_split :
val exists : ('a -> bool) -> 'a array -> bool
val is_empty : 'a array -> bool
+
+val for_all2_no_exn :
+ ('a -> 'b -> bool) ->
+ 'a array ->
+ 'b array ->
+ bool
end = struct
#1 "ext_array.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
@@ -29046,6 +29053,21 @@ let exists p a =
let is_empty arr =
Array.length arr = 0
+
+
+let rec unsafe_loop index len p xs ys =
+ if index >= len then true
+ else
+ p
+ (Array.unsafe_get xs index)
+ (Array.unsafe_get ys index) &&
+ unsafe_loop (succ index) len p xs ys
+
+let for_all2_no_exn p xs ys =
+ let len_xs = Array.length xs in
+ let len_ys = Array.length ys in
+ len_xs = len_ys &&
+ unsafe_loop 0 len_xs p xs ys
end
module Ext_json_types
= struct
diff --git a/jscomp/bin/bsppx.ml b/jscomp/bin/bsppx.ml
index 716ba306c0..123788fe2d 100644
--- a/jscomp/bin/bsppx.ml
+++ b/jscomp/bin/bsppx.ml
@@ -5628,7 +5628,8 @@ let is_valid_source_name name : check_result =
match check_any_suffix_case_then_chop name [
".ml";
".re";
- ".mli"; ".mll"; ".rei"
+ ".mli";
+ ".rei"
] with
| None -> Suffix_mismatch
| Some x ->
@@ -10806,6 +10807,12 @@ val find_and_split :
val exists : ('a -> bool) -> 'a array -> bool
val is_empty : 'a array -> bool
+
+val for_all2_no_exn :
+ ('a -> 'b -> bool) ->
+ 'a array ->
+ 'b array ->
+ bool
end = struct
#1 "ext_array.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
@@ -10994,6 +11001,21 @@ let exists p a =
let is_empty arr =
Array.length arr = 0
+
+
+let rec unsafe_loop index len p xs ys =
+ if index >= len then true
+ else
+ p
+ (Array.unsafe_get xs index)
+ (Array.unsafe_get ys index) &&
+ unsafe_loop (succ index) len p xs ys
+
+let for_all2_no_exn p xs ys =
+ let len_xs = Array.length xs in
+ let len_ys = Array.length ys in
+ len_xs = len_ys &&
+ unsafe_loop 0 len_xs p xs ys
end
module Ext_json_types
= struct
diff --git a/jscomp/bin/whole_compiler.ml b/jscomp/bin/whole_compiler.ml
index 2d7cbd45b8..ab9349c140 100644
--- a/jscomp/bin/whole_compiler.ml
+++ b/jscomp/bin/whole_compiler.ml
@@ -21186,7 +21186,8 @@ let is_valid_source_name name : check_result =
match check_any_suffix_case_then_chop name [
".ml";
".re";
- ".mli"; ".mll"; ".rei"
+ ".mli";
+ ".rei"
] with
| None -> Suffix_mismatch
| Some x ->
@@ -58856,6 +58857,12 @@ val find_and_split :
val exists : ('a -> bool) -> 'a array -> bool
val is_empty : 'a array -> bool
+
+val for_all2_no_exn :
+ ('a -> 'b -> bool) ->
+ 'a array ->
+ 'b array ->
+ bool
end = struct
#1 "ext_array.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
@@ -59044,6 +59051,21 @@ let exists p a =
let is_empty arr =
Array.length arr = 0
+
+
+let rec unsafe_loop index len p xs ys =
+ if index >= len then true
+ else
+ p
+ (Array.unsafe_get xs index)
+ (Array.unsafe_get ys index) &&
+ unsafe_loop (succ index) len p xs ys
+
+let for_all2_no_exn p xs ys =
+ let len_xs = Array.length xs in
+ let len_ys = Array.length ys in
+ len_xs = len_ys &&
+ unsafe_loop 0 len_xs p xs ys
end
module Ext_json_types
= struct
diff --git a/jscomp/bsb/bsb_build_ui.ml b/jscomp/bsb/bsb_build_ui.ml
index 909b5908aa..bab20a509e 100644
--- a/jscomp/bsb/bsb_build_ui.ml
+++ b/jscomp/bsb/bsb_build_ui.ml
@@ -111,7 +111,8 @@ type parsing_cxt = {
no_dev : bool ;
dir_index : dir_index ;
cwd : string ;
- root : string
+ root : string;
+ cut_generators : bool
}
let handle_list_files acc
@@ -157,6 +158,29 @@ let (++) (u : t) (v : t) =
globbed_dirs = u.globbed_dirs @ v.globbed_dirs ;
}
+let get_input_output loc_start (content : Ext_json_types.t array) =
+ let error () =
+ Bsb_exception.failf ~loc:loc_start {| invalid edge format, expect ["input" , ":", "output" ]|}
+ in
+ match Ext_array.find_and_split content
+ (fun x () -> match x with Str { str =":"} -> true | _ -> false )
+ () with
+ | `No_split -> error ()
+ | `Split ( output, input) ->
+ Ext_array.to_list_map (fun (x : Ext_json_types.t) ->
+ match x with
+ | Str {str = ":"} ->
+ error ()
+ | Str {str } ->
+ Some str
+ | _ -> None) output ,
+ Ext_array.to_list_map (fun (x : Ext_json_types.t) ->
+ match x with
+ | Str {str = ":"} ->
+ error ()
+ | Str {str} ->
+ Some str (* More rigirous error checking: It would trigger a ninja syntax error *)
+ | _ -> None) input
(** [dir_index] can be inherited *)
let rec
@@ -196,7 +220,7 @@ and parsing_source ({no_dev; dir_index ; cwd} as cxt ) (x : Ext_json_types.t )
| _ -> empty
and parsing_source_dir_map
- ({ cwd = dir} as cxt )
+ ({ cwd = dir; no_dev; cut_generators } as cxt )
(x : Ext_json_types.t String_map.t)
(* { dir : xx, files : ... } [dir] is already extracted *)
=
@@ -206,36 +230,42 @@ and parsing_source_dir_map
let cur_update_queue = ref [] in
let cur_globbed_dirs = ref [] in
let generators : build_generator list ref = ref [] in
- (* begin match String_map.find_opt Bsb_build_schemas.generators x with *)
- (* | Some (Arr { content }) -> *)
- (* (\* TODO: need check is dev build or not *\) *)
- (* content |> Array.iter (fun (x : Ext_json_types.t) -> *)
- (* match x with *)
- (* | Obj { map = generator; loc} -> *)
- (* begin match String_map.find_opt Bsb_build_schemas.input generator, *)
- (* String_map.find_opt Bsb_build_schemas.output generator, *)
- (* String_map.find_opt Bsb_build_schemas.cmd generator *)
- (* with *)
- (* | Some (Str{str = input}), Some (Str {str = output}), Some (Str {str = cmd})-> *)
- (* generators := {input ; output ; cmd } :: !generators; *)
- (* (\** Now adding source files, it may be re-added again later when scanning files *)
- (* *\) *)
- (* begin match Ext_string.is_valid_source_name output with *)
- (* | Good -> *)
- (* cur_sources := Binary_cache.map_update ~dir !cur_sources output *)
- (* | Invalid_module_name -> *)
- (* () *)
- (* (\*Format.fprintf Format.err_formatter warning_unused_file output dir *\) *)
- (* | Suffix_mismatch -> () *)
- (* end *)
- (* | _ -> *)
- (* Bsb_exception.failf ~loc "Invalid generator format" *)
- (* end *)
- (* | _ -> () *)
- (* ) *)
- (* | Some _ | None -> () *)
- (* end *)
- (* ; *)
+ begin match String_map.find_opt Bsb_build_schemas.generators x with
+ | Some (Arr { content ; loc_start}) ->
+ (* Need check is dev build or not *)
+ content
+ |> Array.iter (fun (x : Ext_json_types.t) ->
+ match x with
+ | Obj { map = generator; loc} ->
+ begin match String_map.find_opt Bsb_build_schemas.name generator,
+ String_map.find_opt Bsb_build_schemas.edge generator
+ with
+ | Some (Str{str = command}), Some (Arr {content })->
+
+ let output, input = get_input_output loc_start content in
+ if not cut_generators && not no_dev then begin
+ generators := {input ; output ; command } :: !generators
+ end;
+ (** Now adding source files, it may be re-added again later when scanning files *)
+ output |> List.iter begin fun output ->
+ begin match Ext_string.is_valid_source_name output with
+ | Good ->
+ cur_sources := Binary_cache.map_update ~dir !cur_sources output
+ | Invalid_module_name ->
+ ()
+ (*Format.fprintf Format.err_formatter warning_unused_file output dir *)
+ | Suffix_mismatch -> ()
+ end
+ end
+ | _ ->
+ Bsb_exception.failf ~loc "Invalid generator format"
+ end
+ | _ -> Bsb_exception.failf ~loc:(Ext_json.loc_of x) "Invalid generator format"
+ )
+ | Some x -> Bsb_exception.failf ~loc:(Ext_json.loc_of x ) "Invalid generators format"
+ | None -> ()
+ end
+ ;
begin match String_map.find_opt Bsb_build_schemas.files x with
| Some (Arr {loc_start;loc_end; content = [||] }) -> (* [ ] *)
let tasks, files = handle_list_files !cur_sources cxt loc_start loc_end in
diff --git a/jscomp/bsb/bsb_build_ui.mli b/jscomp/bsb/bsb_build_ui.mli
index 346c819c9d..efdfb07687 100644
--- a/jscomp/bsb/bsb_build_ui.mli
+++ b/jscomp/bsb/bsb_build_ui.mli
@@ -46,7 +46,7 @@ type file_group =
type t =
- { files : file_group list ;
+ { files : file_group list ; (* flattened list of directories *)
intervals : Ext_file_pp.interval list ;
globbed_dirs : string list ;
@@ -60,7 +60,8 @@ type parsing_cxt = {
no_dev : bool ;
dir_index : dir_index ;
cwd : string ;
- root : string
+ root : string ;
+ cut_generators : bool
}
diff --git a/jscomp/bsb/bsb_config_parse.ml b/jscomp/bsb/bsb_config_parse.ml
index ea75b0c8db..88e1572fdb 100644
--- a/jscomp/bsb/bsb_config_parse.ml
+++ b/jscomp/bsb/bsb_config_parse.ml
@@ -275,6 +275,7 @@ let interpret_json
let js_post_build_cmd = ref None in
let built_in_package = ref None in
let generate_merlin = ref true in
+ let generators = ref String_map.empty in
let package_specs = ref (String_set.singleton Literals.commonjs) in
(* When we plan to add more deps here,
Make sure check it is consistent that for nested deps, we have a
@@ -288,7 +289,7 @@ let interpret_json
2. we need store it so that we can call ninja correctly
*)
let entries = ref Bsb_default.main_entries in
-
+ let cut_generators = ref false in
let config_json_chan = open_in_bin config_json in
let global_data = Ext_json_parse.parse_json_from_chan config_json_chan in
match global_data with
@@ -342,6 +343,20 @@ let interpret_json
else Bsb_build_util.resolve_bsb_magic_file ~cwd ~desc:Bsb_build_schemas.ppx_flags p
)
))
+ |? (Bsb_build_schemas.cut_generators, `Bool (fun b -> cut_generators := b))
+ |? (Bsb_build_schemas.generators, `Arr (fun s ->
+ generators :=
+ Array.fold_left (fun acc json ->
+ match (json : Ext_json_types.t) with
+ | Obj {map = m ; loc} ->
+ begin match String_map.find_opt Bsb_build_schemas.name m,
+ String_map.find_opt Bsb_build_schemas.command m with
+ | Some (Str {str = name}), Some ( Str {str = command}) ->
+ String_map.add name command acc
+ | _, _ ->
+ Bsb_exception.failf ~loc {| generators exepect format like { "name" : "cppo", "command" : "cppo $in -o $out"} |}
+ end
+ | _ -> acc ) String_map.empty s ))
|? (Bsb_build_schemas.refmt, `Str (fun s ->
refmt := Some (Bsb_build_util.resolve_bsb_magic_file ~cwd ~desc:Bsb_build_schemas.refmt s) ))
|? (Bsb_build_schemas.refmt_flags, `Arr (fun s -> refmt_flags := get_list_string s))
@@ -349,8 +364,11 @@ let interpret_json
|> ignore ;
begin match String_map.find_opt Bsb_build_schemas.sources map with
| Some x ->
- let res = Bsb_build_ui.parsing_sources {no_dev; dir_index =
- Bsb_build_ui.lib_dir_index; cwd = Filename.current_dir_name; root = cwd} x in
+ let res = Bsb_build_ui.parsing_sources
+ {no_dev;
+ dir_index =
+ Bsb_build_ui.lib_dir_index; cwd = Filename.current_dir_name;
+ root = cwd; cut_generators = !cut_generators} x in
if generate_watch_metadata then
generate_sourcedirs_meta cwd res ;
begin match List.sort Ext_file_pp.interval_compare res.intervals with
@@ -394,7 +412,9 @@ let interpret_json
built_in_dependency = !built_in_package;
generate_merlin = !generate_merlin ;
reason_react_jsx = !reason_react_jsx ;
- entries = !entries
+ entries = !entries;
+ generators = !generators ;
+ cut_generators = !cut_generators
}
| None -> failwith "no sources specified, please checkout the schema for more details"
end
diff --git a/jscomp/bsb/bsb_config_types.ml b/jscomp/bsb/bsb_config_types.ml
index 6428003038..d198ac7249 100644
--- a/jscomp/bsb/bsb_config_types.ml
+++ b/jscomp/bsb/bsb_config_types.ml
@@ -57,4 +57,6 @@ type t =
generate_merlin : bool ;
reason_react_jsx : bool ; (* whether apply PPX transform or not*)
entries : entries_t list ;
+ generators : string String_map.t ;
+ cut_generators : bool; (* note when used as a dev mode, we will always ignore it *)
}
diff --git a/jscomp/bsb/bsb_gen.ml b/jscomp/bsb/bsb_gen.ml
index d7b63b4429..38d3ca8ead 100644
--- a/jscomp/bsb/bsb_gen.ml
+++ b/jscomp/bsb/bsb_gen.ml
@@ -47,30 +47,29 @@ let dash_i = "-I"
let refmt_exe = "refmt.exe"
let dash_ppx = "-ppx"
-let ninja_required_version = "ninja_required_version = 1.5.1 \n"
-
let output_ninja
~cwd
~bsc_dir
- {
- Bsb_config_types.package_name;
- ocamllex;
- external_includes;
- bsc_flags ;
- ppx_flags;
- bs_dependencies;
- bs_dev_dependencies;
- refmt;
- refmt_flags;
- js_post_build_cmd;
- package_specs;
- bs_file_groups;
- files_to_install;
- built_in_dependency;
- reason_react_jsx
- }
+ ({
+ package_name;
+ ocamllex;
+ external_includes;
+ bsc_flags ;
+ ppx_flags;
+ bs_dependencies;
+ bs_dev_dependencies;
+ refmt;
+ refmt_flags;
+ js_post_build_cmd;
+ package_specs;
+ bs_file_groups;
+ files_to_install;
+ built_in_dependency;
+ reason_react_jsx;
+ generators ;
+ } : Bsb_config_types.t)
=
- let () = Bsb_rule.reset () in
+ let custom_rules = Bsb_rule.reset generators in
let bsc = bsc_dir // bsc_exe in (* The path to [bsc.exe] independent of config *)
let bsdep = bsc_dir // bsb_helper_exe in (* The path to [bsb_heler.exe] *)
(* let builddir = Bsb_config.lib_bs in *)
@@ -80,7 +79,6 @@ let output_ninja
let oc = open_out_bin (cwd // Bsb_config.lib_bs // Literals.build_ninja) in
begin
let () =
- output_string oc ninja_required_version ;
output_string oc "bs_package_flags = ";
output_string oc ("-bs-package-name " ^ package_name);
output_string oc "\n";
@@ -158,7 +156,8 @@ let output_ninja
static_resources;
in
let all_info =
- Bsb_ninja.handle_file_groups oc
+ Bsb_ninja.handle_file_groups oc
+ ~custom_rules
~js_post_build_cmd ~package_specs ~files_to_install bs_file_groups Bsb_ninja.zero in
let () =
List.iter (fun x -> Bsb_ninja.output_build oc
diff --git a/jscomp/bsb/bsb_ninja.ml b/jscomp/bsb/bsb_ninja.ml
index 214bb6ad06..7b3ef82f0f 100644
--- a/jscomp/bsb/bsb_ninja.ml
+++ b/jscomp/bsb/bsb_ninja.ml
@@ -156,7 +156,8 @@ let (++) (us : info) (vs : info) =
let install_file (file : string) files_to_install =
String_hash_set.add files_to_install (Ext_filename.chop_extension_if_any file )
-let handle_file_group oc ~package_specs ~js_post_build_cmd
+let handle_file_group oc ~custom_rules
+ ~package_specs ~js_post_build_cmd
(files_to_install : String_hash_set.t) acc (group: Bsb_build_ui.file_group) : info =
let handle_module_info oc module_name
( module_info : Binary_cache.module_info)
@@ -166,11 +167,11 @@ let handle_file_group oc ~package_specs ~js_post_build_cmd
| Export_all -> true
| Export_none -> false
| Export_set set -> String_set.mem module_name set in
- let emit_build (kind : [`Ml | `Mll | `Re | `Mli | `Rei ]) file_input : info =
+ let emit_build (kind : [`Ml | `Re | `Mli | `Rei ]) file_input : info =
let filename_sans_extension = Filename.chop_extension file_input in
let input = Bsb_config.proj_rel file_input in
let output_file_sans_extension = filename_sans_extension in
- let output_ml = output_file_sans_extension ^ Literals.suffix_ml in
+ (*let output_ml = output_file_sans_extension ^ Literals.suffix_ml in*)
let output_mlast = output_file_sans_extension ^ Literals.suffix_mlast in
let output_mlastd = output_file_sans_extension ^ Literals.suffix_mlastd in
let output_mliast = output_file_sans_extension ^ Literals.suffix_mliast in
@@ -204,20 +205,20 @@ let handle_file_group oc ~package_specs ~js_post_build_cmd
]
)
in
- if kind = `Mll then
+ (*if kind = `Mll then
output_build oc
~output:output_ml
~input
- ~rule: Rules.build_ml_from_mll ;
+ ~rule: Rules.build_ml_from_mll ;*)
begin match kind with
- | `Mll
+ (*| `Mll*)
| `Ml
| `Re ->
let input, rule =
if kind = `Re then
input, Rules.build_ast_and_deps_from_reason_impl
- else if kind = `Mll then
- output_ml, Rules.build_ast_and_deps
+ (*else if kind = `Mll then
+ output_ml, Rules.build_ast_and_deps*)
else
input, Rules.build_ast_and_deps
in
@@ -305,25 +306,29 @@ let handle_file_group oc ~package_specs ~js_post_build_cmd
emit_build `Rei rei_file
| Mli_empty -> zero
end ++
- begin match module_info.mll with
- | Some mll_file ->
- begin match module_info.ml with
- | Ml_empty -> emit_build `Mll mll_file
- | Ml input | Re input ->
- failwith ("both "^ mll_file ^ " and " ^ input ^ " are found in source listings" )
- end
- | None -> zero
- end ++ info
+ info
in
- (*
+ let map_to_source_dir =
+ (fun x -> Bsb_config.proj_rel (group.dir //x )) in
group.generators
- |> List.iter (fun ({output; input; cmd} : Bsb_build_ui.generator)->
- output_build oc ~output:(Bsb_config.proj_rel output)
- ~input:(Bsb_config.proj_rel input)
- ~rule:cmd
- );
- *) (* we need create a rule for it --
+ |> List.iter (fun ({output; input; command} : Bsb_build_ui.build_generator)->
+ begin match String_map.find_opt command custom_rules with
+ | None -> Ext_pervasives.failwithf ~loc:__LOC__ "custom rule %s used but not defined" command
+ | Some rule ->
+ begin match output, input with
+ | output::outputs, input::inputs ->
+ output_build oc
+ ~outputs:(List.map map_to_source_dir outputs)
+ ~inputs:(List.map map_to_source_dir inputs)
+ ~output:(map_to_source_dir output)
+ ~input:(map_to_source_dir input)
+ ~rule
+ | [], _ (* either output or input can not be empty *)
+ | _, [] -> assert false (* Error should be raised earlier *)
+ end
+ end
+ ); (* we need create a rule for it --
{[
rule ocamllex
]}
@@ -337,6 +342,6 @@ let handle_file_group oc ~package_specs ~js_post_build_cmd
let handle_file_groups
oc ~package_specs ~js_post_build_cmd
- ~files_to_install
+ ~files_to_install ~custom_rules
(file_groups : Bsb_build_ui.file_group list) st =
- List.fold_left (handle_file_group oc ~package_specs ~js_post_build_cmd files_to_install ) st file_groups
+ List.fold_left (handle_file_group oc ~package_specs ~custom_rules ~js_post_build_cmd files_to_install ) st file_groups
diff --git a/jscomp/bsb/bsb_ninja.mli b/jscomp/bsb/bsb_ninja.mli
index a895f04752..6eab6b6b7b 100644
--- a/jscomp/bsb/bsb_ninja.mli
+++ b/jscomp/bsb/bsb_ninja.mli
@@ -62,6 +62,7 @@ val handle_file_groups : out_channel ->
package_specs:Bsb_config.package_specs ->
js_post_build_cmd:string option ->
files_to_install:String_hash_set.t ->
+ custom_rules:Bsb_rule.t String_map.t ->
Bsb_build_ui.file_group list ->
info -> info
diff --git a/jscomp/bsb/bsb_rule.ml b/jscomp/bsb/bsb_rule.ml
index 7c86cdb6c3..e0862c5814 100644
--- a/jscomp/bsb/bsb_rule.ml
+++ b/jscomp/bsb/bsb_rule.ml
@@ -61,6 +61,7 @@ let print_rule oc ~description ?restat ?depfile ~command name =
output_string oc " description = " ; output_string oc description; output_string oc "\n"
+(** allocate an unique name for such rule*)
let define
~command
?depfile
@@ -68,19 +69,23 @@ let define
?(description = "\027[34mBuilding\027[39m \027[2m${out}\027[22m") (* blue, dim *)
name
=
+ let rule_name = ask_name name in
let rec self = {
used = false;
- rule_name = ask_name name ;
+ rule_name ;
name = fun oc ->
if not self.used then
begin
- print_rule oc ~description ?depfile ?restat ~command name;
+ print_rule oc ~description ?depfile ?restat ~command rule_name;
self.used <- true
end ;
- self.rule_name
+ rule_name
} in self
+
+
+
let build_ast_and_deps =
define
~command:"${bsc} ${pp_flags} ${ppx_flags} ${bsc_flags} -c -o ${out} -bs-syntax-only -bs-binary-ast ${in}"
@@ -165,18 +170,28 @@ let build_cmi =
~depfile:"${in}.d"
"build_cmi" (* the compiler should always consult [.cmi], current the vanilla ocaml compiler only consult [.cmi] when [.mli] found*)
-let reset () =
- rule_id := 0;
- rule_names := String_set.empty;
- build_ast_and_deps.used <- false ;
- build_ast_and_deps_from_reason_impl.used <- false ;
- build_ast_and_deps_from_reason_intf.used <- false ;
- build_bin_deps.used <- false;
- reload.used <- false;
- copy_resources.used <- false ;
- build_ml_from_mll.used <- false ;
- build_cmj_js.used <- false;
- build_cmj_cmi_js.used <- false ;
- build_cmi.used <- false
+(* a snapshot of rule_names environment*)
+let built_in_rule_names = !rule_names
+let built_in_rule_id = !rule_id
+
+let reset (custom_rules : string String_map.t) =
+ begin
+ rule_id := built_in_rule_id;
+ rule_names := built_in_rule_names;
+
+ build_ast_and_deps.used <- false ;
+ build_ast_and_deps_from_reason_impl.used <- false ;
+ build_ast_and_deps_from_reason_intf.used <- false ;
+ build_bin_deps.used <- false;
+ reload.used <- false;
+ copy_resources.used <- false ;
+ build_ml_from_mll.used <- false ;
+ build_cmj_js.used <- false;
+ build_cmj_cmi_js.used <- false ;
+ build_cmi.used <- false ;
+ String_map.mapi (fun name command ->
+ define ~command name
+ ) custom_rules
+ end
diff --git a/jscomp/bsb/bsb_rule.mli b/jscomp/bsb/bsb_rule.mli
index ef256fb5b6..0ead6cdeb7 100644
--- a/jscomp/bsb/bsb_rule.mli
+++ b/jscomp/bsb/bsb_rule.mli
@@ -26,14 +26,8 @@
type t
-val get_name : t -> out_channel -> string
-val define :
- command:string ->
- ?depfile:string ->
- ?restat:unit ->
- ?description:string ->
- string -> t
+val get_name : t -> out_channel -> string
val build_ast_and_deps : t
val build_ast_and_deps_from_reason_impl : t
@@ -46,4 +40,15 @@ val build_cmj_js : t
val build_cmj_cmi_js : t
val build_cmi : t
-val reset : unit -> unit
+
+(** rules are generally composed of built-in rules and customized rules, there are two design choices:
+ 1. respect custom rules with the same name, then we need adjust our built-in
+ rules dynamically in case the conflict.
+ 2. respect our built-in rules, then we only need re-load custom rules for each bsconfig.json
+*)
+
+
+(** Since now we generate ninja files per bsconfig.json in a single process,
+ we must make sure it is re-entrant
+*)
+val reset : string String_map.t -> t String_map.t
diff --git a/jscomp/bsb/bsb_templates.ml b/jscomp/bsb/bsb_templates.ml
index 1bf95f1b38..7589899779 100644
--- a/jscomp/bsb/bsb_templates.ml
+++ b/jscomp/bsb/bsb_templates.ml
@@ -6,32 +6,51 @@ let root = OCamlRes.Res.([
"\n\
\n\
let () = Js.log \"Hello, BuckleScript\"")]) ;
- File (".gitignore",
- "*.exe\n\
- *.obj\n\
- *.out\n\
- *.compile\n\
- *.native\n\
- *.byte\n\
- *.cmo\n\
- *.annot\n\
- *.cmi\n\
- *.cmx\n\
- *.cmt\n\
- *.cmti\n\
- *.cma\n\
- *.a\n\
- *.cmxa\n\
- *.obj\n\
- *~\n\
- *.annot\n\
- *.cmj\n\
- *.bak\n\
- lib/bs\n\
- *.mlast\n\
- *.mliast\n\
- .vscode\n\
- .merlin") ;
+ File ("README.md",
+ "\n\
+ \n\
+ # Build\n\
+ ```\n\
+ npm run build\n\
+ ```\n\
+ \n\
+ # Watch\n\
+ \n\
+ ```\n\
+ npm run watch\n\
+ ```\n\
+ \n\
+ \n\
+ # Editor\n\
+ If you use `vscode`, Press `Windows + Shift + B` it will build automatically") ;
+ File ("package.json",
+ "{\n\
+ \ \"name\": \"${bsb:name}\",\n\
+ \ \"version\": \"${bsb:proj-version}\",\n\
+ \ \"scripts\": {\n\
+ \ \"clean\": \"bsb -clean-world\",\n\
+ \ \"build\": \"bsb -make-world\",\n\
+ \ \"watch\": \"bsb -make-world -w\"\n\
+ \ },\n\
+ \ \"keywords\": [\n\
+ \ \"BuckleScript\"\n\
+ \ ],\n\
+ \ \"license\": \"MIT\",\n\
+ \ \"devDependencies\": {\n\
+ \ \"bs-platform\": \"${bsb:bs-version}\"\n\
+ \ }\n\
+ }") ;
+ File ("bsconfig.json",
+ "{\n\
+ \ \"name\": \"${bsb:name}\",\n\
+ \ \"version\": \"${bsb:proj-version}\",\n\
+ \ \"sources\": [\n\
+ \ \"src\"\n\
+ \ ],\n\
+ \ \"bs-dependencies\" : [\n\
+ \ // add your bs-dependencies here \n\
+ \ ]\n\
+ }") ;
Dir (".vscode", [
File ("tasks.json",
"{\n\
@@ -72,58 +91,37 @@ let root = OCamlRes.Res.([
\ ]\n\
\ }\n\
}")]) ;
- File ("package.json",
- "{\n\
- \ \"name\": \"${bsb:name}\",\n\
- \ \"version\": \"${bsb:proj-version}\",\n\
- \ \"scripts\": {\n\
- \ \"clean\": \"bsb -clean-world\",\n\
- \ \"build\": \"bsb -make-world\",\n\
- \ \"watch\": \"bsb -make-world -w\"\n\
- \ },\n\
- \ \"keywords\": [\n\
- \ \"BuckleScript\"\n\
- \ ],\n\
- \ \"license\": \"MIT\",\n\
- \ \"devDependencies\": {\n\
- \ \"bs-platform\": \"${bsb:bs-version}\"\n\
- \ }\n\
- }") ;
- File ("bsconfig.json",
- "{\n\
- \ \"name\": \"${bsb:name}\",\n\
- \ \"version\": \"${bsb:proj-version}\",\n\
- \ \"sources\": [\n\
- \ \"src\"\n\
- \ ],\n\
- \ \"bs-dependencies\" : [\n\
- \ // add your bs-dependencies here \n\
- \ ]\n\
- }") ;
- File ("README.md",
- "\n\
- \n\
- # Build\n\
- ```\n\
- npm run build\n\
- ```\n\
- \n\
- # Watch\n\
- \n\
- ```\n\
- npm run watch\n\
- ```\n\
- \n\
- \n\
- # Editor\n\
- If you use `vscode`, Press `Windows + Shift + B` it will build automatically")]) ;
+ File (".gitignore",
+ "*.exe\n\
+ *.obj\n\
+ *.out\n\
+ *.compile\n\
+ *.native\n\
+ *.byte\n\
+ *.cmo\n\
+ *.annot\n\
+ *.cmi\n\
+ *.cmx\n\
+ *.cmt\n\
+ *.cmti\n\
+ *.cma\n\
+ *.a\n\
+ *.cmxa\n\
+ *.obj\n\
+ *~\n\
+ *.annot\n\
+ *.cmj\n\
+ *.bak\n\
+ lib/bs\n\
+ *.mlast\n\
+ *.mliast\n\
+ .vscode\n\
+ .merlin")]) ;
Dir ("minimal", [
Dir ("src", [ File ("main.ml", "")]) ;
- File (".gitignore",
- "lib\n\
- node_modules\n\
- .merlin\n\
- npm-debug.log") ;
+ File ("README.md",
+ "\n\
+ \ # ${bsb:name}") ;
File ("package.json",
"{\n\
\ \"name\": \"${bsb:name}\",\n\
@@ -146,7 +144,9 @@ let root = OCamlRes.Res.([
\ \"name\": \"${bsb:name}\",\n\
\ \"sources\": [\"src\"]\n\
}") ;
- File ("README.md",
- "\n\
- \ # ${bsb:name}")])
+ File (".gitignore",
+ "lib\n\
+ node_modules\n\
+ .merlin\n\
+ npm-debug.log")])
])
diff --git a/jscomp/common/binary_cache.ml b/jscomp/common/binary_cache.ml
index 96a1f4116c..d4c20665c3 100644
--- a/jscomp/common/binary_cache.ml
+++ b/jscomp/common/binary_cache.ml
@@ -37,7 +37,7 @@ type module_info =
{
mli : mli_kind ;
ml : ml_kind ;
- mll : string option ;
+ (*mll : string option ;*)
}
@@ -52,7 +52,7 @@ let module_info_magic_number = "BSBUILD20161019"
let dir_of_module_info (x : module_info)
=
match x with
- | { mli; ml; mll} ->
+ | { mli; ml; } ->
begin match mli with
| Mli s | Rei s ->
Filename.dirname s
@@ -60,11 +60,11 @@ let dir_of_module_info (x : module_info)
begin match ml with
| Ml s | Re s ->
Filename.dirname s
- | Ml_empty ->
- begin match mll with
+ | Ml_empty -> Ext_string.empty
+ (*begin match mll with
| None -> ""
| Some s -> Filename.dirname s
- end
+ end *)
end
end
@@ -86,7 +86,7 @@ let read_build_cache bsbuild : t =
let bsbuild_cache = ".bsbuild"
-let empty_module_info = {mli = Mli_empty ; mll = None ; ml = Ml_empty}
+let empty_module_info = {mli = Mli_empty ; ml = Ml_empty}
let adjust_module_info x suffix name =
match suffix with
@@ -94,7 +94,6 @@ let adjust_module_info x suffix name =
| ".re" -> {x with ml = Re name}
| ".mli" -> {x with mli = Mli name}
| ".rei" -> { x with mli = Rei name}
- | ".mll" -> {x with mll = Some name}
| _ -> failwith ("don't know what to do with " ^ name)
let map_update ?dir (map : file_group_rouces) name : file_group_rouces =
diff --git a/jscomp/common/binary_cache.mli b/jscomp/common/binary_cache.mli
index c80106ee55..9c4d82798e 100644
--- a/jscomp/common/binary_cache.mli
+++ b/jscomp/common/binary_cache.mli
@@ -36,7 +36,6 @@ type module_info =
{
mli : mli_kind ;
ml : ml_kind ;
- mll : string option
}
type file_group_rouces = module_info String_map.t
diff --git a/jscomp/depends/depends_post_process.ml b/jscomp/depends/depends_post_process.ml
index 236b260f1c..606136ccb6 100644
--- a/jscomp/depends/depends_post_process.ml
+++ b/jscomp/depends/depends_post_process.ml
@@ -72,7 +72,7 @@ let handle_bin_depfile
Array.fold_left
(fun ((acc, len) as v) k ->
match String_map.find_opt k data.(0) with
- | Some ({ml = Ml s | Re s } | {mll = Some s })
+ | Some {ml = Ml s | Re s }
->
let new_file = op_concat @@ Filename.chop_extension s ^ suffix_inteface
in (new_file :: acc , len + String.length new_file + length_space)
@@ -84,7 +84,7 @@ let handle_bin_depfile
if index = 0 then v
else
begin match String_map.find_opt k data.(index) with
- | Some ({ml = Ml s | Re s } | {mll = Some s })
+ | Some {ml = Ml s | Re s }
->
let new_file = op_concat @@ Filename.chop_extension s ^ suffix_inteface
in (new_file :: acc , len + String.length new_file + length_space)
@@ -112,7 +112,6 @@ let handle_bin_depfile
(fun ((acc, len) as v) k ->
match String_map.find_opt k data.(0) with
| Some ({ ml = Ml f | Re f }
- | { mll = Some f }
| { mli = Mli f | Rei f }) ->
let new_file = (op_concat @@ Filename.chop_extension f ^ Literals.suffix_cmi) in
(new_file :: acc , len + String.length new_file + length_space)
@@ -122,7 +121,6 @@ let handle_bin_depfile
else
begin match String_map.find_opt k data.(index) with
| Some ({ ml = Ml f | Re f }
- | { mll = Some f }
| { mli = Mli f | Rei f }) ->
let new_file = (op_concat @@ Filename.chop_extension f ^ Literals.suffix_cmi) in
(new_file :: acc , len + String.length new_file + length_space)
diff --git a/jscomp/ext/ext_array.ml b/jscomp/ext/ext_array.ml
index 3d3863093d..e338cfffc0 100644
--- a/jscomp/ext/ext_array.ml
+++ b/jscomp/ext/ext_array.ml
@@ -183,4 +183,19 @@ let exists p a =
let is_empty arr =
- Array.length arr = 0
\ No newline at end of file
+ Array.length arr = 0
+
+
+let rec unsafe_loop index len p xs ys =
+ if index >= len then true
+ else
+ p
+ (Array.unsafe_get xs index)
+ (Array.unsafe_get ys index) &&
+ unsafe_loop (succ index) len p xs ys
+
+let for_all2_no_exn p xs ys =
+ let len_xs = Array.length xs in
+ let len_ys = Array.length ys in
+ len_xs = len_ys &&
+ unsafe_loop 0 len_xs p xs ys
\ No newline at end of file
diff --git a/jscomp/ext/ext_array.mli b/jscomp/ext/ext_array.mli
index 4a4309cad1..35445814e8 100644
--- a/jscomp/ext/ext_array.mli
+++ b/jscomp/ext/ext_array.mli
@@ -68,4 +68,10 @@ val find_and_split :
val exists : ('a -> bool) -> 'a array -> bool
-val is_empty : 'a array -> bool
\ No newline at end of file
+val is_empty : 'a array -> bool
+
+val for_all2_no_exn :
+ ('a -> 'b -> bool) ->
+ 'a array ->
+ 'b array ->
+ bool
\ No newline at end of file
diff --git a/jscomp/ext/ext_json.ml b/jscomp/ext/ext_json.ml
index a43c84602f..123b10bb5e 100644
--- a/jscomp/ext/ext_json.ml
+++ b/jscomp/ext/ext_json.ml
@@ -1,4 +1,26 @@
-
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
type callback =
[
@@ -14,7 +36,7 @@ type callback =
| `Id of (Ext_json_types.t -> unit )
]
-
+
type path = string list
type status =
@@ -24,26 +46,26 @@ type status =
let test ?(fail=(fun () -> ())) key
(cb : callback) (m : Ext_json_types.t String_map.t)
- =
- begin match String_map.find_exn key m, cb with
- | exception Not_found ->
- begin match cb with `Not_found f -> f ()
- | _ -> fail ()
- end
- | True _, `Bool cb -> cb true
- | False _, `Bool cb -> cb false
- | Flo {flo = s} , `Flo cb -> cb s
- | Obj {map = b} , `Obj cb -> cb b
- | Arr {content}, `Arr cb -> cb content
- | Arr {content; loc_start ; loc_end}, `Arr_loc cb ->
- cb content loc_start loc_end
- | Null _, `Null cb -> cb ()
- | Str {str = s }, `Str cb -> cb s
- | Str {str = s ; loc }, `Str_loc cb -> cb s loc
- | any , `Id cb -> cb any
- | _, _ -> fail ()
- end;
- m
+ =
+ begin match String_map.find_exn key m, cb with
+ | exception Not_found ->
+ begin match cb with `Not_found f -> f ()
+ | _ -> fail ()
+ end
+ | True _, `Bool cb -> cb true
+ | False _, `Bool cb -> cb false
+ | Flo {flo = s} , `Flo cb -> cb s
+ | Obj {map = b} , `Obj cb -> cb b
+ | Arr {content}, `Arr cb -> cb content
+ | Arr {content; loc_start ; loc_end}, `Arr_loc cb ->
+ cb content loc_start loc_end
+ | Null _, `Null cb -> cb ()
+ | Str {str = s }, `Str cb -> cb s
+ | Str {str = s ; loc }, `Str_loc cb -> cb s loc
+ | any , `Id cb -> cb any
+ | _, _ -> fail ()
+ end;
+ m
let query path (json : Ext_json_types.t ) =
let rec aux acc paths json =
match path with
@@ -67,4 +89,50 @@ let loc_of (x : Ext_json_types.t) =
| Arr p -> p.loc_start
| Obj p -> p.loc
| Flo p -> p.loc
-
+
+
+let rec equal
+ (x : Ext_json_types.t)
+ (y : Ext_json_types.t) =
+ match x with
+ | Null _ -> (* [%p? Null _ ] *)
+ begin match y with
+ | Null _ -> true
+ | _ -> false end
+ | Str {str } ->
+ begin match y with
+ | Str {str = str2} -> str = str2
+ | _ -> false end
+ | Flo {flo}
+ ->
+ begin match y with
+ | Flo {flo = flo2} ->
+ flo = flo2
+ | _ -> false
+ end
+ | True _ ->
+ begin match y with
+ | True _ -> true
+ | _ -> false
+ end
+ | False _ ->
+ begin match y with
+ | False _ -> true
+ | _ -> false
+ end
+ | Arr {content}
+ ->
+ begin match y with
+ | Arr {content = content2}
+ ->
+ Ext_array.for_all2_no_exn equal content content2
+ | _ -> false
+ end
+
+ | Obj {map} ->
+ begin match y with
+ | Obj { map = map2} ->
+ String_map.equal equal map map2
+ | _ -> false
+ end
+
diff --git a/jscomp/ext/ext_json.mli b/jscomp/ext/ext_json.mli
index 82ecc0d028..917b46da71 100644
--- a/jscomp/ext/ext_json.mli
+++ b/jscomp/ext/ext_json.mli
@@ -54,3 +54,5 @@ val test:
val query : path -> Ext_json_types.t -> status
val loc_of : Ext_json_types.t -> Ext_position.t
+
+val equal : Ext_json_types.t -> Ext_json_types.t -> bool
\ No newline at end of file
diff --git a/jscomp/ext/ext_json_write.ml b/jscomp/ext/ext_json_write.ml
new file mode 100644
index 0000000000..551f1ed794
--- /dev/null
+++ b/jscomp/ext/ext_json_write.ml
@@ -0,0 +1,86 @@
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+
+(** poor man's serialization *)
+
+let quot x =
+ "\"" ^ String.escaped x ^ "\""
+
+let rec encode_aux (x : Ext_json_types.t )
+ (buf : Buffer.t) : unit =
+ let a str = Buffer.add_string buf str in
+ match x with
+ | Null _ -> a "null"
+ | Str {str = s } -> a (quot s)
+ | Flo {flo = s} ->
+ a s (*
+ since our parsing keep the original float representation, we just dump it as is, there is no cases like [nan] *)
+ | Arr {content} ->
+ begin match content with
+ | [||] -> a "[]"
+ | _ ->
+ a "[ ";
+ encode_aux
+ (Array.unsafe_get content 0)
+ buf ;
+ for i = 1 to Array.length content - 1 do
+ a " , ";
+ encode_aux
+ (Array.unsafe_get content i)
+ buf
+ done;
+ a " ]"
+ end
+ | True _ -> a "true"
+ | False _ -> a "false"
+ | Obj {map} ->
+ if String_map.is_empty map then
+ a "{}"
+ else
+ begin
+ (*prerr_endline "WEIRD";
+ prerr_endline (string_of_int @@ String_map.cardinal map ); *)
+ a "{ ";
+ let _ : int = String_map.fold (fun k v i ->
+ if i <> 0 then begin
+ a " , "
+ end;
+ a (quot k);
+ a " : ";
+ encode_aux v buf ;
+ i + 1
+ ) map 0 in
+ a " }"
+ end
+
+
+let to_string (x : Ext_json_types.t) =
+ let buf = Buffer.create 1024 in
+ encode_aux x buf ;
+ Buffer.contents buf
+
+let to_channel (oc : out_channel) x =
+ let buf = Buffer.create 1024 in
+ encode_aux x buf ;
+ Buffer.output_buffer oc buf
diff --git a/jscomp/ext/ext_json_write.mli b/jscomp/ext/ext_json_write.mli
new file mode 100644
index 0000000000..ca9baff165
--- /dev/null
+++ b/jscomp/ext/ext_json_write.mli
@@ -0,0 +1,29 @@
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+
+
+val to_string : Ext_json_types.t -> string
+
+
+val to_channel : out_channel -> Ext_json_types.t -> unit
\ No newline at end of file
diff --git a/jscomp/ext/ext_string.ml b/jscomp/ext/ext_string.ml
index ac70c7bb53..2fd03f4546 100644
--- a/jscomp/ext/ext_string.ml
+++ b/jscomp/ext/ext_string.ml
@@ -364,7 +364,8 @@ let is_valid_source_name name : check_result =
match check_any_suffix_case_then_chop name [
".ml";
".re";
- ".mli"; ".mll"; ".rei"
+ ".mli";
+ ".rei"
] with
| None -> Suffix_mismatch
| Some x ->
diff --git a/jscomp/ounit_tests/ounit_array_tests.ml b/jscomp/ounit_tests/ounit_array_tests.ml
index 35b70a66fa..80d1ae796c 100644
--- a/jscomp/ounit_tests/ounit_array_tests.ml
+++ b/jscomp/ounit_tests/ounit_array_tests.ml
@@ -47,4 +47,32 @@ let suites =
[|1;2;3;4;5;6|] []
=~ [2;4;6]
end;
+
+ __LOC__ >:: begin fun _ ->
+ OUnit.assert_bool __LOC__
+ (Ext_array.for_all2_no_exn
+ (=)
+ [|1;2;3|]
+ [|1;2;3|]
+ )
+ end;
+ __LOC__ >:: begin fun _ ->
+ OUnit.assert_bool __LOC__
+ (Ext_array.for_all2_no_exn
+ (=) [||] [||]
+ );
+ OUnit.assert_bool __LOC__
+ (not @@ Ext_array.for_all2_no_exn
+ (=) [||] [|1|]
+ )
+ end
+ ;
+ __LOC__ >:: begin fun _ ->
+ OUnit.assert_bool __LOC__
+ (not (Ext_array.for_all2_no_exn
+ (=)
+ [|1;2;3|]
+ [|1;2;33|]
+ ))
+ end
]
\ No newline at end of file
diff --git a/jscomp/ounit_tests/ounit_json_tests.ml b/jscomp/ounit_tests/ounit_json_tests.ml
index 557be4af7a..7a6dcaa6e9 100644
--- a/jscomp/ounit_tests/ounit_json_tests.ml
+++ b/jscomp/ounit_tests/ounit_json_tests.ml
@@ -1,16 +1,66 @@
let ((>::),
- (>:::)) = OUnit.((>::),(>:::))
+ (>:::)) = OUnit.((>::),(>:::))
open Ext_json_parse
let (|?) m (key, cb) =
- m |> Ext_json.test key cb
+ m |> Ext_json.test key cb
+let id_parsing_serializing x =
+ let normal_s =
+ Ext_json_write.to_string ( Ext_json_parse.parse_json_from_string x )
+ in
+ let normal_ss =
+ Ext_json_write.to_string
+ (Ext_json_parse.parse_json_from_string normal_s)
+ in
+ if normal_s <> normal_ss then
+ begin
+ prerr_endline "ERROR";
+ prerr_endline normal_s ;
+ prerr_endline normal_ss ;
+ end;
+ OUnit.assert_equal ~cmp:(fun (x:string) y -> x = y) normal_s normal_ss
+
+let id_parsing_x2 x =
+ let stru = Ext_json_parse.parse_json_from_string x in
+ let normal_s = Ext_json_write.to_string stru in
+ let normal_ss = (Ext_json_parse.parse_json_from_string normal_s) in
+ if Ext_json.equal stru normal_ss then
+ true
+ else begin
+ prerr_endline "ERROR";
+ prerr_endline normal_s;
+ Format.fprintf Format.err_formatter
+ "%a@.%a@." Ext_pervasives.pp_any stru Ext_pervasives.pp_any normal_ss;
+
+ prerr_endline (Ext_json_write.to_string normal_ss);
+ false
+ end
+
+let test_data =
+ [{|
+ {}
+ |};
+ {| [] |};
+ {| [1,2,3]|};
+ {| ["x", "y", 1,2,3 ]|};
+ {| { "x" : 3, "y" : "x", "z" : [1,2,3, "x"] }|};
+ {| {"x " : true , "y" : false , "z\"" : 1} |}
+ ]
exception Parse_error
let suites =
__FILE__
>:::
[
+
+ __LOC__ >:: begin fun _ ->
+ List.iter id_parsing_serializing test_data
+ end;
+
+ __LOC__ >:: begin fun _ ->
+ List.iteri (fun i x -> OUnit.assert_bool (__LOC__ ^ string_of_int i ) (id_parsing_x2 x)) test_data
+ end;
"empty_json" >:: begin fun _ ->
let v =parse_json_from_string "{}" in
match v with
@@ -29,7 +79,7 @@ let suites =
(OUnit.assert_raises Parse_error @@ fun _ ->
try parse_json_from_string {| [,]|} with _ -> raise Parse_error);
OUnit.assert_raises Parse_error @@ fun _ ->
- try parse_json_from_string {| {,}|} with _ -> raise Parse_error
+ try parse_json_from_string {| {,}|} with _ -> raise Parse_error
end;
"two trails" >:: begin fun _ ->
(OUnit.assert_raises Parse_error @@ fun _ ->
diff --git a/jscomp/ounit_tests/ounit_string_tests.ml b/jscomp/ounit_tests/ounit_string_tests.ml
index af0272b5d4..9d46705eab 100644
--- a/jscomp/ounit_tests/ounit_string_tests.ml
+++ b/jscomp/ounit_tests/ounit_string_tests.ml
@@ -50,7 +50,7 @@ let suites =
__LOC__ >:: begin fun _ ->
OUnit.assert_bool __LOC__ @@
List.for_all (fun x -> Ext_string.is_valid_source_name x = Good)
- ["x.ml"; "x.mli"; "x.re"; "x.rei"; "x.mll";
+ ["x.ml"; "x.mli"; "x.re"; "x.rei";
"A_x.ml"; "ab.ml"; "a_.ml"; "a__.ml";
"ax.ml"];
OUnit.assert_bool __LOC__ @@ not @@
diff --git a/jscomp/test/ext_array.js b/jscomp/test/ext_array.js
index 8bcb02a4ae..535ce23851 100644
--- a/jscomp/test/ext_array.js
+++ b/jscomp/test/ext_array.js
@@ -283,6 +283,31 @@ function is_empty(arr) {
return +(arr.length === 0);
}
+function unsafe_loop(_index, len, p, xs, ys) {
+ while(true) {
+ var index = _index;
+ if (index >= len) {
+ return /* true */1;
+ } else if (Curry._2(p, xs[index], ys[index])) {
+ _index = index + 1 | 0;
+ continue ;
+
+ } else {
+ return /* false */0;
+ }
+ };
+}
+
+function for_all2_no_exn(p, xs, ys) {
+ var len_xs = xs.length;
+ var len_ys = ys.length;
+ if (len_xs === len_ys) {
+ return unsafe_loop(0, len_xs, p, xs, ys);
+ } else {
+ return /* false */0;
+ }
+}
+
exports.reverse_range = reverse_range;
exports.reverse_in_place = reverse_in_place;
exports.reverse = reverse;
@@ -301,4 +326,6 @@ exports.find_with_index = find_with_index;
exports.find_and_split = find_and_split;
exports.exists = exists;
exports.is_empty = is_empty;
+exports.unsafe_loop = unsafe_loop;
+exports.for_all2_no_exn = for_all2_no_exn;
/* No side effect */
diff --git a/jscomp/test/ext_string.js b/jscomp/test/ext_string.js
index 1dc625b624..cca48aa998 100644
--- a/jscomp/test/ext_string.js
+++ b/jscomp/test/ext_string.js
@@ -569,11 +569,8 @@ function is_valid_source_name(name) {
/* :: */[
".mli",
/* :: */[
- ".mll",
- /* :: */[
- ".rei",
- /* [] */0
- ]
+ ".rei",
+ /* [] */0
]
]
]
diff --git a/site/docsource/Build-system-support.adoc b/site/docsource/Build-system-support.adoc
index 41a38fe6b3..6f5d803661 100644
--- a/site/docsource/Build-system-support.adoc
+++ b/site/docsource/Build-system-support.adoc
@@ -349,3 +349,51 @@ make depend // <2>
Now in your working directory, type `watchman -j < build.json` and enjoy the lightning build speed.
+
+=== Customize rules (generators support, @since 1.7.4)
+
+It is quite common that programmers use some pre-processors to generate some bolierpolate code during developement.
+
+Note pre-processors can be classified as two categories, one is system-dependent which should be delayed until running on user machines, the other is system-indepdent , lex, yacc, m4, re2c, etc, which could be executed anytime.
+
+BuckleScript has built in support for conditional compilation, this section is about the second part, since it is system-indepdent, we ask users to always generate such code and check in before shipping, this would help cut the dependencies for end users.
+
+A typical example would be like this
+
+.Bsb using ocamlyacc
+[source,js]
+-----------
+{
+ "generators" : [
+ { "name" : "ocamlyacc" ,
+ "command" : "ocamlyacc $in" }
+ ],
+ ...,
+ "sources" : {
+ "dir" : "src",
+ "generators" : [
+ {
+ "name" : "ocamlyacc",
+ "edge" : ["test.ml", "test.mli", ":", "test.mly"]
+ }
+ ]
+ }
+}
+-----------
+
+
+Note `ocamlyacc` will generate in `test.ml` and `test.mli` in the same directory with `test.mly`, user should check in generated file since then users would not need run ocamlyacc again, this would apply to `menhir` as well.
+
+When users are developing current project, `bsb` will track the dependencies between `test.ml` and `test.mly` properly, when released
+as a package, `bsb` will cut such dependency, so that users will
+only need the generated `test.ml`, to help test such behavior in development mode, users could set it manually
+
+[source,js]
+-----------
+{
+ ...,
+ "cut-generators" : true
+}
+-----------
+
+Then `bsb` will not re-generate `test.ml` whenever `test.mly` changes.
\ No newline at end of file