diff --git a/CHANGELOG.md b/CHANGELOG.md index 2cf147d667..2616f95612 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -36,6 +36,8 @@ subset of the arguments, and return a curried type with the remaining ones https Also, `(. int) => string => bool` is not equivalen to `(. int, string) => bool` anymore. These are only breaking changes for unformatted code. - Exponentiation operator `**` is now right-associative. `2. ** 3. ** 2.` now compile to `Math.pow(2, Math.pow(3, 2))` and not anymore `Math.pow(Math.pow(2, 3), 2)`. Parentheses can be used to change precedence. +- Remove unsafe ``` j`$(a)$(b)` ``` interpolation deprecated in compiler version 10 https://github.com/rescript-lang/rescript-compiler/pull/6068 +- Remove deprecated module `Printexc` #### :bug: Bug Fix @@ -79,6 +81,7 @@ These are only breaking changes for unformatted code. - Better error message for extension point https://github.com/rescript-lang/rescript-compiler/pull/6057 - Improve format check help https://github.com/rescript-lang/rescript-compiler/pull/6056 +- Deprecate unsafe ``` j`$(a)$(b)` ``` interpolation: use string templates ``` `${a}${b}` ``` instead https://github.com/rescript-lang/rescript-compiler/pull/6067 # 10.1.3 diff --git a/jscomp/build_tests/super_errors/expected/jinterp.res.expected b/jscomp/build_tests/super_errors/expected/jinterp.res.expected new file mode 100644 index 0000000000..7eb7ad35cb --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/jinterp.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/jinterp.res:3:10-21 + + 1 │ + 2 │ let a = 11 + 3 │ let b = j`number $(a)` + + The unsafe j`$(a)$(b)` interpolation was removed, use string template `${a}${b}` instead. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/fixtures/jinterp.res b/jscomp/build_tests/super_errors/fixtures/jinterp.res new file mode 100644 index 0000000000..cd6608feed --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/jinterp.res @@ -0,0 +1,3 @@ + +let a = 11 +let b = j`number $(a)` \ No newline at end of file diff --git a/jscomp/frontend/ast_utf8_string_interp.ml b/jscomp/frontend/ast_utf8_string_interp.ml index 43808973fc..bd48760007 100644 --- a/jscomp/frontend/ast_utf8_string_interp.ml +++ b/jscomp/frontend/ast_utf8_string_interp.ml @@ -62,20 +62,6 @@ type cxt = { type exn += Error of pos * pos * error -let pp_error fmt err = - Format.pp_print_string fmt - @@ - match err with - | Invalid_code_point -> "Invalid code point" - | Unterminated_backslash -> "\\ ended unexpectedly" - | Invalid_escape_code c -> "Invalid escape code: " ^ String.make 1 c - | Invalid_hex_escape -> "Invalid \\x escape" - | Invalid_unicode_escape -> "Invalid \\u escape" - | Unterminated_variable -> "$ unterminated" - | Unmatched_paren -> "Unmatched paren" - | Invalid_syntax_of_var s -> - "`" ^ s ^ "' is not a valid syntax of interpolated identifer" - let valid_lead_identifier_char x = match x with 'a' .. 'z' | '_' -> true | _ -> false @@ -97,31 +83,6 @@ let valid_identifier s = | ' ' | '\n' | '\t' -> true | _ -> false *) -(** - FIXME: multiple line offset - if there is no line offset. Note {|{j||} border will never trigger a new line -*) -let update_position border ({ lnum; offset; byte_bol } : pos) - (pos : Lexing.position) = - if lnum = 0 then { pos with pos_cnum = pos.pos_cnum + border + offset } - (* When no newline, the column number is [border + offset] *) - else - { - pos with - pos_lnum = pos.pos_lnum + lnum; - pos_bol = pos.pos_cnum + border + byte_bol; - pos_cnum = - pos.pos_cnum + border + byte_bol + offset - (* when newline, the column number is [offset] *); - } - -let update border (start : pos) (finish : pos) (loc : Location.t) : Location.t = - let start_pos = loc.loc_start in - { - loc with - loc_start = update_position border start start_pos; - loc_end = update_position border finish start_pos; - } (** Note [Var] kind can not be mpty *) let empty_segment { content } = Ext_string.is_empty content @@ -308,21 +269,6 @@ let transform_test s = check_and_transform 0 s 0 cxt; List.rev cxt.segments -(** TODO: test empty var $() $ failure, - Allow identifers x.A.y *) - -open Ast_helper - -(** Longident.parse "Pervasives.^" *) -let concat_ident : Longident.t = Ldot (Lident "Pervasives", "^") -(* FIXME: remove deps on `Pervasives` *) - -(* JS string concatMany *) -(* Ldot (Ldot (Lident "Js", "String2"), "concat") *) - -(* Longident.parse "Js.String.make" *) -let to_string_ident : Longident.t = Ldot (Ldot (Lident "Js", "String2"), "make") - module Delim = struct let parse_processed = function | None -> Some External_arg_spec.DNone @@ -332,102 +278,43 @@ module Delim = struct type interpolation = | Js (* string interpolation *) - | J (* old unsafe interpolation *) | Unrecognized (* no interpolation: delimiter not recognized *) - let parse_unprocessed = function + let parse_unprocessed loc = function | "js" -> Js - | "j" -> J + | "j" -> + Location.raise_errorf ~loc + "The unsafe j`$(a)$(b)` interpolation was removed, use string template `${a}${b}` instead." | _ -> Unrecognized let escaped_j_delimiter = "*j" (* not user level syntax allowed *) - let unescaped_j_delimiter = "j" let unescaped_js_delimiter = "js" let escaped = Some escaped_j_delimiter end -let border = String.length "{j|" - -let aux loc (segment : segment) ~to_string_ident : Parsetree.expression = - match segment with - | { start; finish; kind; content } -> ( - match kind with - | String -> - let loc = update border start finish loc in - Ast_compatible.const_exp_string content ?delimiter:Delim.escaped ~loc - | Var (soffset, foffset) -> - let loc = - { - loc with - loc_start = update_position (soffset + border) start loc.loc_start; - loc_end = update_position (foffset + border) finish loc.loc_start; - } - in - Ast_compatible.apply_simple ~loc - (Exp.ident ~loc { loc; txt = to_string_ident }) - [ Exp.ident ~loc { loc; txt = Lident content } ]) - -let concat_exp a_loc x ~(lhs : Parsetree.expression) : Parsetree.expression = - let loc = Bs_loc.merge a_loc lhs.pexp_loc in - Ast_compatible.apply_simple ~loc - (Exp.ident { txt = concat_ident; loc }) - [ lhs; aux loc x ~to_string_ident:(Longident.Lident "__unsafe_cast") ] - -(* Invariant: the [lhs] is always of type string *) -let rec handle_segments loc (rev_segments : segment list) = - match rev_segments with - | [] -> Ast_compatible.const_exp_string ~loc "" ?delimiter:Delim.escaped - | [ segment ] -> aux loc segment ~to_string_ident (* string literal *) - | { content = "" } :: rest -> handle_segments loc rest - | a :: rest -> concat_exp loc a ~lhs:(handle_segments loc rest) - -let transform_interp loc s = - let s_len = String.length s in - let buf = Buffer.create (s_len * 2) in - try - let cxt : cxt = - { - segment_start = { lnum = 0; offset = 0; byte_bol = 0 }; - buf; - s_len; - segments = []; - pos_lnum = 0; - byte_bol = 0; - pos_bol = 0; - } - in - - check_and_transform 0 s 0 cxt; - handle_segments loc cxt.segments - with Error (start, pos, error) -> - Location.raise_errorf ~loc:(update border start pos loc) "%a" pp_error error - let transform_exp (e : Parsetree.expression) s delim : Parsetree.expression = - match Delim.parse_unprocessed delim with + match Delim.parse_unprocessed e.pexp_loc delim with | Js -> let js_str = Ast_utf8_string.transform e.pexp_loc s in { e with pexp_desc = Pexp_constant (Pconst_string (js_str, Delim.escaped)); } - | J -> transform_interp e.pexp_loc s | Unrecognized -> e let transform_pat (p : Parsetree.pattern) s delim : Parsetree.pattern = - match Delim.parse_unprocessed delim with + match Delim.parse_unprocessed p.ppat_loc delim with | Js -> let js_str = Ast_utf8_string.transform p.ppat_loc s in { p with ppat_desc = Ppat_constant (Pconst_string (js_str, Delim.escaped)); } - | J (* No j interpolation on patterns *) | Unrecognized -> p let is_unicode_string opt = Ext_string.equal opt Delim.escaped_j_delimiter let is_unescaped s = - Ext_string.equal s Delim.unescaped_j_delimiter - || Ext_string.equal s Delim.unescaped_js_delimiter + Ext_string.equal s Delim.unescaped_js_delimiter let parse_processed_delim = Delim.parse_processed diff --git a/jscomp/ounit_tests/ounit_unicode_tests.ml b/jscomp/ounit_tests/ounit_unicode_tests.ml index 65826252e5..0c289da83e 100644 --- a/jscomp/ounit_tests/ounit_unicode_tests.ml +++ b/jscomp/ounit_tests/ounit_unicode_tests.ml @@ -243,80 +243,4 @@ let suites = 0,2,0,3,String,")" ] end; - __LOC__ >:: begin fun _ -> - match Ast_utf8_string_interp.transform_test {j| $( ()) |j} - with - |exception Ast_utf8_string_interp.Error - ({lnum = 0; offset = 1; byte_bol = 0}, - {lnum = 0; offset = 6; byte_bol = 0}, Invalid_syntax_of_var " (") - -> OUnit.assert_bool __LOC__ true - | _ -> OUnit.assert_bool __LOC__ false - end - ; - __LOC__ >:: begin fun _ -> - match Ast_utf8_string_interp.transform_test {|$()|} - with - | exception Ast_utf8_string_interp.Error ({lnum = 0; offset = 0; byte_bol = 0}, - {lnum = 0; offset = 3; byte_bol = 0}, Invalid_syntax_of_var "") - -> OUnit.assert_bool __LOC__ true - | _ -> OUnit.assert_bool __LOC__ false - end - ; - __LOC__ >:: begin fun _ -> - match Ast_utf8_string_interp.transform_test {|$ ()|} - with - | exception Ast_utf8_string_interp.Error - ({lnum = 0; offset = 0; byte_bol = 0}, - {lnum = 0; offset = 1; byte_bol = 0}, Invalid_syntax_of_var "") - -> OUnit.assert_bool __LOC__ true - | _ -> OUnit.assert_bool __LOC__ false - end ; - __LOC__ >:: begin fun _ -> - match Ast_utf8_string_interp.transform_test {|$()|} with - | exception Ast_utf8_string_interp.Error - ({lnum = 0; offset = 0; byte_bol = 0}, - {lnum = 0; offset = 3; byte_bol = 0}, Invalid_syntax_of_var "") - -> OUnit.assert_bool __LOC__ true - | _ -> OUnit.assert_bool __LOC__ false - end - ; - __LOC__ >:: begin fun _ -> - match Ast_utf8_string_interp.transform_test {|$(hello world)|} with - | exception Ast_utf8_string_interp.Error - ({lnum = 0; offset = 0; byte_bol = 0}, - {lnum = 0; offset = 14; byte_bol = 0}, Invalid_syntax_of_var "hello world") - -> OUnit.assert_bool __LOC__ true - | _ -> OUnit.assert_bool __LOC__ false - end - - - ; - __LOC__ >:: begin fun _ -> - match Ast_utf8_string_interp.transform_test {|$( hi*) |} with - | exception Ast_utf8_string_interp.Error - ({lnum = 0; offset = 0; byte_bol = 0}, - {lnum = 0; offset = 7; byte_bol = 0}, Invalid_syntax_of_var " hi*") - -> - OUnit.assert_bool __LOC__ true - | _ -> OUnit.assert_bool __LOC__ false - end; - __LOC__ >:: begin fun _ -> - match Ast_utf8_string_interp.transform_test {|xx $|} with - | exception Ast_utf8_string_interp.Error - ({lnum = 0; offset = 3; byte_bol = 0}, - {lnum = 0; offset = 3; byte_bol = 0}, Unterminated_variable) - -> - OUnit.assert_bool __LOC__ true - | _ -> OUnit.assert_bool __LOC__ false - end ; - - __LOC__ >:: begin fun _ -> - match Ast_utf8_string_interp.transform_test {|$(world |}; with - | exception Ast_utf8_string_interp.Error - ({lnum = 0; offset = 0; byte_bol = 0}, - {lnum = 0; offset = 9; byte_bol = 0}, Unmatched_paren) - -> - OUnit.assert_bool __LOC__ true - | _ -> OUnit.assert_bool __LOC__ false - end ] diff --git a/jscomp/stdlib-406/arg.ml b/jscomp/stdlib-406/arg.ml deleted file mode 100644 index f2137c00ac..0000000000 --- a/jscomp/stdlib-406/arg.ml +++ /dev/null @@ -1,359 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Damien Doligez, projet Para, 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 Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -type key = string -type doc = string -type usage_msg = string -type anon_fun = (string -> unit) - -type spec = - | Unit of (unit -> unit) (* Call the function with unit argument *) - | Bool of (bool -> unit) (* Call the function with a bool argument *) - | Set of bool ref (* Set the reference to true *) - | Clear of bool ref (* Set the reference to false *) - | String of (string -> unit) (* Call the function with a string argument *) - | Set_string of string ref (* Set the reference to the string argument *) - | Int of (int -> unit) (* Call the function with an int argument *) - | Set_int of int ref (* Set the reference to the int argument *) - | Float of (float -> unit) (* Call the function with a float argument *) - | Set_float of float ref (* Set the reference to the float argument *) - | Tuple of spec list (* Take several arguments according to the - spec list *) - | Symbol of string list * (string -> unit) - (* Take one of the symbols as argument and - call the function with the symbol. *) - | Rest of (string -> unit) (* Stop interpreting keywords and call the - function with each remaining argument *) - | Expand of (string -> string array) (* If the remaining arguments to process - are of the form - [["-foo"; "arg"] @ rest] where "foo" is - registered as [Expand f], then the - arguments [f "arg" @ rest] are - processed. Only allowed in - [parse_and_expand_argv_dynamic]. *) - -exception Bad of string -exception Help of string - -type error = - | Unknown of string - | Wrong of string * string * string (* option, actual, expected *) - | Missing of string - | Message of string - -exception Stop of error (* used internally *) - - - -let rec assoc3 x l = - match l with - | [] -> raise Not_found - | (y1, y2, _) :: _ when y1 = x -> y2 - | _ :: t -> assoc3 x t - - -let split s = - let i = String.index s '=' in - let len = String.length s in - String.sub s 0 i, String.sub s (i+1) (len-(i+1)) - - -let make_symlist prefix sep suffix l = - match l with - | [] -> "" - | h::t -> (List.fold_left (fun x y -> x ^ sep ^ y) (prefix ^ h) t) ^ suffix - - -let print_spec buf (key, spec, doc) = - if String.length doc > 0 then - match spec with - | Symbol (l, _) -> - let sym = make_symlist "{" "|" "}" l in - Buffer.add_string buf {j| $(key) $(sym)$(doc)\n|j} - | _ -> - Buffer.add_string buf {j| $(key) $(doc)\n|j} - - - -let help_action () = raise (Stop (Unknown "-help")) - -let add_help speclist = - let add1 = - try ignore (assoc3 "-help" speclist); [] - with Not_found -> - ["-help", Unit help_action, " Display this list of options"] - and add2 = - try ignore (assoc3 "--help" speclist); [] - with Not_found -> - ["--help", Unit help_action, " Display this list of options"] - in - speclist @ (add1 @ add2) - - -let usage_b buf speclist errmsg = - Buffer.add_string buf {j|$(errmsg)\n|j}; - List.iter (print_spec buf) (add_help speclist) - - -let usage_string speclist errmsg = - let b = Buffer.create 200 in - usage_b b speclist errmsg; - Buffer.contents b - - -let usage speclist errmsg = - Js.log (usage_string speclist errmsg) - - -let current = ref 0 - -let bool_of_string_opt x = - try Some (bool_of_string x) - with Invalid_argument _ -> None - -let int_of_string_opt x = - try Some (int_of_string x) - with Failure _ -> None - -let float_of_string_opt x = - try Some (float_of_string x) - with Failure _ -> None - -let parse_and_expand_argv_dynamic_aux allow_expand current argv speclist anonfun errmsg = - let initpos = !current in - let convert_error error = - (* convert an internal error to a Bad/Help exception - *or* add the program name as a prefix and the usage message as a suffix - to an user-raised Bad exception. - *) - let b = Buffer.create 200 in - let progname = if initpos < (Array.length !argv) then !argv.(initpos) else "(?)" in - begin match error with - | Unknown "-help" -> () - | Unknown "--help" -> () - | Unknown s -> - Buffer.add_string b {j|$(progname): unknown option '$(s)'.\n|j} - | Missing s -> - Buffer.add_string b {j|$(progname): option '$(s)' needs an argument.\n|j} - | Wrong (opt, arg, expected) -> - Buffer.add_string b {j|$(progname): wrong argument '$(arg)'; option '$(opt)' expects $(expected).\n|j} - | Message s -> (* user error message *) - Buffer.add_string b {j|$(progname): $(s).\n|j} - end; - usage_b b !speclist errmsg; - if error = Unknown "-help" || error = Unknown "--help" - then Help (Buffer.contents b) - else Bad (Buffer.contents b) - in - incr current; - while !current < (Array.length !argv) do - begin try - let s = !argv.(!current) in - if String.length s >= 1 && s.[0] = '-' then begin - let action, follow = - try assoc3 s !speclist, None - with Not_found -> - try - let keyword, arg = split s in - assoc3 keyword !speclist, Some arg - with Not_found -> raise (Stop (Unknown s)) - in - let no_arg () = - match follow with - | None -> () - | Some arg -> raise (Stop (Wrong (s, arg, "no argument"))) in - let get_arg () = - match follow with - | None -> - if !current + 1 < (Array.length !argv) then !argv.(!current + 1) - else raise (Stop (Missing s)) - | Some arg -> arg - in - let consume_arg () = - match follow with - | None -> incr current - | Some _ -> () - in - let rec treat_action = function - | Unit f -> f (); - | Bool f -> - let arg = get_arg () in - begin match bool_of_string_opt arg with - | None -> raise (Stop (Wrong (s, arg, "a boolean"))) - | Some s -> f s - end; - consume_arg (); - | Set r -> no_arg (); r := true; - | Clear r -> no_arg (); r := false; - | String f -> - let arg = get_arg () in - f arg; - consume_arg (); - | Symbol (symb, f) -> - let arg = get_arg () in - if List.mem arg symb then begin - f arg; - consume_arg (); - end else begin - raise (Stop (Wrong (s, arg, "one of: " - ^ (make_symlist "" " " "" symb)))) - end - | Set_string r -> - r := get_arg (); - consume_arg (); - | Int f -> - let arg = get_arg () in - begin match int_of_string_opt arg with - | None -> raise (Stop (Wrong (s, arg, "an integer"))) - | Some x -> f x - end; - consume_arg (); - | Set_int r -> - let arg = get_arg () in - begin match int_of_string_opt arg with - | None -> raise (Stop (Wrong (s, arg, "an integer"))) - | Some x -> r := x - end; - consume_arg (); - | Float f -> - let arg = get_arg () in - begin match float_of_string_opt arg with - | None -> raise (Stop (Wrong (s, arg, "a float"))) - | Some x -> f x - end; - consume_arg (); - | Set_float r -> - let arg = get_arg () in - begin match float_of_string_opt arg with - | None -> raise (Stop (Wrong (s, arg, "a float"))) - | Some x -> r := x - end; - consume_arg (); - | Tuple specs -> - List.iter treat_action specs; - | Rest f -> - while !current < (Array.length !argv) - 1 do - f !argv.(!current + 1); - consume_arg (); - done; - | Expand f -> - if not allow_expand then - raise (Invalid_argument "Arg.Expand is is only allowed with Arg.parse_and_expand_argv_dynamic"); - let arg = get_arg () in - let newarg = f arg in - consume_arg (); - let before = Array.sub !argv 0 (!current + 1) - and after = Array.sub !argv (!current + 1) ((Array.length !argv) - !current - 1) in - argv:= Array.concat [before;newarg;after]; - in - treat_action action end - else anonfun s - with | Bad m -> raise (convert_error (Message m)); - | Stop e -> raise (convert_error e); - end; - incr current - done - -let parse_and_expand_argv_dynamic current argv speclist anonfun errmsg = - parse_and_expand_argv_dynamic_aux true current argv speclist anonfun errmsg - -let parse_argv_dynamic ?(current=current) argv speclist anonfun errmsg = - parse_and_expand_argv_dynamic_aux false current (ref argv) speclist anonfun errmsg - - -let parse_argv ?(current=current) argv speclist anonfun errmsg = - parse_argv_dynamic ~current:current argv (ref speclist) anonfun errmsg - - -let parse l f msg = - try - parse_argv Sys.argv l f msg - with - | Bad msg -> Js.log msg; exit 2 - | Help msg -> Js.log msg; exit 0 - - -let parse_dynamic l f msg = - try - parse_argv_dynamic Sys.argv l f msg - with - | Bad msg -> Js.log msg; exit 2 - | Help msg -> Js.log msg; exit 0 - -let parse_expand l f msg = - try - let argv = ref Sys.argv in - let spec = ref l in - let current = ref (!current) in - parse_and_expand_argv_dynamic current argv spec f msg - with - | Bad msg -> Js.log msg; exit 2 - | Help msg -> Js.log msg; exit 0 - - -let second_word s = - let len = String.length s in - let rec loop n = - if n >= len then len - else if s.[n] = ' ' then loop (n+1) - else n - in - match String.index s '\t' with - | n -> loop (n+1) - | exception Not_found -> - begin match String.index s ' ' with - | n -> loop (n+1) - | exception Not_found -> len - end - - -let max_arg_len cur (kwd, spec, doc) = - match spec with - | Symbol _ -> max cur (String.length kwd) - | _ -> max cur (String.length kwd + second_word doc) - - -let replace_leading_tab s = - let seen = ref false in - String.map (function '\t' when not !seen -> seen := true; ' ' | c -> c) s - -let add_padding len ksd = - match ksd with - | (_, _, "") -> - (* Do not pad undocumented options, so that they still don't show up when - * run through [usage] or [parse]. *) - ksd - | (kwd, (Symbol _ as spec), msg) -> - let cutcol = second_word msg in - let spaces = String.make ((max 0 (len - cutcol)) + 3) ' ' in - (kwd, spec, "\n" ^ spaces ^ replace_leading_tab msg) - | (kwd, spec, msg) -> - let cutcol = second_word msg in - let kwd_len = String.length kwd in - let diff = len - kwd_len - cutcol in - if diff <= 0 then - (kwd, spec, replace_leading_tab msg) - else - let spaces = String.make diff ' ' in - let prefix = String.sub (replace_leading_tab msg) 0 cutcol in - let suffix = String.sub msg cutcol (String.length msg - cutcol) in - (kwd, spec, prefix ^ spaces ^ suffix) - - -let align ?(limit=max_int) speclist = - let completed = add_help speclist in - let len = List.fold_left max_arg_len 0 completed in - let len = min len limit in - List.map (add_padding len) completed diff --git a/jscomp/stdlib-406/arg.res b/jscomp/stdlib-406/arg.res new file mode 100644 index 0000000000..7dadf08940 --- /dev/null +++ b/jscomp/stdlib-406/arg.res @@ -0,0 +1,427 @@ +/* ************************************************************************ */ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/* ************************************************************************ */ + +type key = string +type doc = string +type usage_msg = string +type anon_fun = string => unit + +type rec spec = + | Unit(unit => unit) /* Call the function with unit argument */ + | Bool(bool => unit) /* Call the function with a bool argument */ + | Set(ref) /* Set the reference to true */ + | Clear(ref) /* Set the reference to false */ + | String(string => unit) /* Call the function with a string argument */ + | Set_string(ref) /* Set the reference to the string argument */ + | Int(int => unit) /* Call the function with an int argument */ + | Set_int(ref) /* Set the reference to the int argument */ + | Float(float => unit) /* Call the function with a float argument */ + | Set_float(ref) /* Set the reference to the float argument */ + | Tuple(list) /* Take several arguments according to the + spec list */ + + | Symbol(list, string => unit) + /* Take one of the symbols as argument and + call the function with the symbol. */ + | Rest(string => unit) /* Stop interpreting keywords and call the + function with each remaining argument */ + + | Expand( + string => array, + ) /* If the remaining arguments to process + are of the form + [["-foo"; "arg"] @ rest] where "foo" is + registered as [Expand f], then the + arguments [f "arg" @ rest] are + processed. Only allowed in + [parse_and_expand_argv_dynamic]. */ + +exception Bad(string) +exception Help(string) + +type error = + | Unknown(string) + | Wrong(string, string, string) /* option, actual, expected */ + | Missing(string) + | Message(string) + +exception Stop(error) /* used internally */ + +let rec assoc3 = (x, l) => + switch l { + | list{} => raise(Not_found) + | list{(y1, y2, _), ..._} if y1 == x => y2 + | list{_, ...t} => assoc3(x, t) + } + +let split = s => { + let i = String.index(s, '=') + let len = String.length(s) + (String.sub(s, 0, i), String.sub(s, i + 1, len - (i + 1))) +} + +let make_symlist = (prefix, sep, suffix, l) => + switch l { + | list{} => "" + | list{h, ...t} => List.fold_left((x, y) => x ++ (sep ++ y), prefix ++ h, t) ++ suffix + } + +let print_spec = (buf, (key, spec, doc)) => + if String.length(doc) > 0 { + switch spec { + | Symbol(l, _) => + let sym = make_symlist("{", "|", "}", l) + Buffer.add_string(buf, ` ${key} ${sym}${doc}\n`) + | _ => Buffer.add_string(buf, ` ${key} ${doc}\n`) + } + } + +let help_action = () => raise(Stop(Unknown("-help"))) + +let add_help = speclist => { + let add1 = try { + ignore(assoc3("-help", speclist)) + list{} + } catch { + | Not_found => list{("-help", Unit(help_action), " Display this list of options")} + } + and add2 = try { + ignore(assoc3("--help", speclist)) + list{} + } catch { + | Not_found => list{("--help", Unit(help_action), " Display this list of options")} + } + + \"@"(speclist, \"@"(add1, add2)) +} + +let usage_b = (buf, speclist, errmsg) => { + Buffer.add_string(buf, `${errmsg}\n`) + List.iter(print_spec(buf), add_help(speclist)) +} + +let usage_string = (speclist, errmsg) => { + let b = Buffer.create(200) + usage_b(b, speclist, errmsg) + Buffer.contents(b) +} + +let usage = (speclist, errmsg) => Js.log(usage_string(speclist, errmsg)) + +let current = ref(0) + +let bool_of_string_opt = x => + try Some(bool_of_string(x)) catch { + | Invalid_argument(_) => None + } + +let int_of_string_opt = x => + try Some(int_of_string(x)) catch { + | Failure(_) => None + } + +let float_of_string_opt = x => + try Some(float_of_string(x)) catch { + | Failure(_) => None + } + +let parse_and_expand_argv_dynamic_aux = ( + allow_expand, + current, + argv, + speclist, + anonfun, + errmsg, +) => { + let initpos = current.contents + let convert_error = error => { + /* convert an internal error to a Bad/Help exception + *or* add the program name as a prefix and the usage message as a suffix + to an user-raised Bad exception. + */ + let b = Buffer.create(200) + let progname = if initpos < Array.length(argv.contents) { + argv.contents[initpos] + } else { + "(?)" + } + switch error { + | Unknown("-help") => () + | Unknown("--help") => () + | Unknown(s) => Buffer.add_string(b, `${progname}: unknown option '${s}'.\n`) + | Missing(s) => Buffer.add_string(b, `${progname}: option '${s}' needs an argument.\n`) + | Wrong(opt, arg, expected) => + Buffer.add_string( + b, + `${progname}: wrong argument '${arg}'; option '${opt}' expects ${expected}.\n`, + ) + | Message(s) => + /* user error message */ + Buffer.add_string(b, `${progname}: ${s}.\n`) + } + usage_b(b, speclist.contents, errmsg) + if error == Unknown("-help") || error == Unknown("--help") { + Help(Buffer.contents(b)) + } else { + Bad(Buffer.contents(b)) + } + } + + incr(current) + while current.contents < Array.length(argv.contents) { + try { + let s = argv.contents[current.contents] + if String.length(s) >= 1 && String.get(s, 0) == '-' { + let (action, follow) = try (assoc3(s, speclist.contents), None) catch { + | Not_found => + try { + let (keyword, arg) = split(s) + (assoc3(keyword, speclist.contents), Some(arg)) + } catch { + | Not_found => raise(Stop(Unknown(s))) + } + } + + let no_arg = () => + switch follow { + | None => () + | Some(arg) => raise(Stop(Wrong(s, arg, "no argument"))) + } + let get_arg = () => + switch follow { + | None => + if current.contents + 1 < Array.length(argv.contents) { + argv.contents[current.contents + 1] + } else { + raise(Stop(Missing(s))) + } + | Some(arg) => arg + } + + let consume_arg = () => + switch follow { + | None => incr(current) + | Some(_) => () + } + + let rec treat_action = f => + switch f { + | Unit(f) => f() + | Bool(f) => + let arg = get_arg() + switch bool_of_string_opt(arg) { + | None => raise(Stop(Wrong(s, arg, "a boolean"))) + | Some(s) => f(s) + } + consume_arg() + | Set(r) => + no_arg() + r := true + | Clear(r) => + no_arg() + r := false + | String(f) => + let arg = get_arg() + f(arg) + consume_arg() + | Symbol(symb, f) => + let arg = get_arg() + if List.mem(arg, symb) { + f(arg) + consume_arg() + } else { + raise(Stop(Wrong(s, arg, "one of: " ++ make_symlist("", " ", "", symb)))) + } + | Set_string(r) => + r := get_arg() + consume_arg() + | Int(f) => + let arg = get_arg() + switch int_of_string_opt(arg) { + | None => raise(Stop(Wrong(s, arg, "an integer"))) + | Some(x) => f(x) + } + consume_arg() + | Set_int(r) => + let arg = get_arg() + switch int_of_string_opt(arg) { + | None => raise(Stop(Wrong(s, arg, "an integer"))) + | Some(x) => r := x + } + consume_arg() + | Float(f) => + let arg = get_arg() + switch float_of_string_opt(arg) { + | None => raise(Stop(Wrong(s, arg, "a float"))) + | Some(x) => f(x) + } + consume_arg() + | Set_float(r) => + let arg = get_arg() + switch float_of_string_opt(arg) { + | None => raise(Stop(Wrong(s, arg, "a float"))) + | Some(x) => r := x + } + consume_arg() + | Tuple(specs) => List.iter(treat_action, specs) + | Rest(f) => + while current.contents < Array.length(argv.contents) - 1 { + f(argv.contents[current.contents + 1]) + consume_arg() + } + | Expand(f) => + if !allow_expand { + raise( + Invalid_argument( + "Arg.Expand is is only allowed with Arg.parse_and_expand_argv_dynamic", + ), + ) + } + let arg = get_arg() + let newarg = f(arg) + consume_arg() + let before = Array.sub(argv.contents, 0, current.contents + 1) + and after = Array.sub( + argv.contents, + current.contents + 1, + Array.length(argv.contents) - current.contents - 1, + ) + argv := Array.concat(list{before, newarg, after}) + } + + treat_action(action) + } else { + anonfun(s) + } + } catch { + | Bad(m) => raise(convert_error(Message(m))) + | Stop(e) => raise(convert_error(e)) + } + incr(current) + } +} + +let parse_and_expand_argv_dynamic = (current, argv, speclist, anonfun, errmsg) => + parse_and_expand_argv_dynamic_aux(true, current, argv, speclist, anonfun, errmsg) + +let parse_argv_dynamic = (~current=current, argv, speclist, anonfun, errmsg) => + parse_and_expand_argv_dynamic_aux(false, current, ref(argv), speclist, anonfun, errmsg) + +let parse_argv = (~current=current, argv, speclist, anonfun, errmsg) => + parse_argv_dynamic(~current, argv, ref(speclist), anonfun, errmsg) + +let parse = (l, f, msg) => + try parse_argv(Sys.argv, l, f, msg) catch { + | Bad(msg) => + Js.log(msg) + exit(2) + | Help(msg) => + Js.log(msg) + exit(0) + } + +let parse_dynamic = (l, f, msg) => + try parse_argv_dynamic(Sys.argv, l, f, msg) catch { + | Bad(msg) => + Js.log(msg) + exit(2) + | Help(msg) => + Js.log(msg) + exit(0) + } + +let parse_expand = (l, f, msg) => + try { + let argv = ref(Sys.argv) + let spec = ref(l) + let current = ref(current.contents) + parse_and_expand_argv_dynamic(current, argv, spec, f, msg) + } catch { + | Bad(msg) => + Js.log(msg) + exit(2) + | Help(msg) => + Js.log(msg) + exit(0) + } + +let second_word = s => { + let len = String.length(s) + let rec loop = n => + if n >= len { + len + } else if String.get(s, n) == ' ' { + loop(n + 1) + } else { + n + } + + switch String.index(s, '\t') { + | n => loop(n + 1) + | exception Not_found => + switch String.index(s, ' ') { + | n => loop(n + 1) + | exception Not_found => len + } + } +} + +let max_arg_len = (cur, (kwd, spec, doc)) => + switch spec { + | Symbol(_) => max(cur, String.length(kwd)) + | _ => max(cur, String.length(kwd) + second_word(doc)) + } + +let replace_leading_tab = s => { + let seen = ref(false) + String.map(c => + switch c { + | '\t' if !seen.contents => + seen := true + ' ' + | c => c + } + , s) +} + +let add_padding = (len, ksd) => + switch ksd { + | (_, _, "") => /* Do not pad undocumented options, so that they still don't show up when + * run through [usage] or [parse]. */ + ksd + | (kwd, Symbol(_) as spec, msg) => + let cutcol = second_word(msg) + let spaces = String.make(max(0, len - cutcol) + 3, ' ') + (kwd, spec, "\n" ++ (spaces ++ replace_leading_tab(msg))) + | (kwd, spec, msg) => + let cutcol = second_word(msg) + let kwd_len = String.length(kwd) + let diff = len - kwd_len - cutcol + if diff <= 0 { + (kwd, spec, replace_leading_tab(msg)) + } else { + let spaces = String.make(diff, ' ') + let prefix = String.sub(replace_leading_tab(msg), 0, cutcol) + let suffix = String.sub(msg, cutcol, String.length(msg) - cutcol) + (kwd, spec, prefix ++ (spaces ++ suffix)) + } + } + +let align = (~limit=max_int, speclist) => { + let completed = add_help(speclist) + let len = List.fold_left(max_arg_len, 0, completed) + let len = min(len, limit) + List.map(add_padding(len), completed) +} diff --git a/jscomp/stdlib-406/arg.mli b/jscomp/stdlib-406/arg.resi similarity index 51% rename from jscomp/stdlib-406/arg.mli rename to jscomp/stdlib-406/arg.resi index 44014453b9..529f5e60b2 100644 --- a/jscomp/stdlib-406/arg.mli +++ b/jscomp/stdlib-406/arg.resi @@ -1,19 +1,4 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Damien Doligez, projet Para, 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 Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Parsing of command line arguments. +/*** Parsing of command line arguments. This module provides a general mechanism for extracting options and arguments from the command line to the program. @@ -34,49 +19,53 @@ Examples ([cmd] is assumed to be the command name): - [cmd -flag ](a unit option) - [cmd -int 1 ](an int option with argument [1]) -- [cmd -string foobar ](a string option with argument ["foobar"]) +- [cmd -string foobar ](a string option with argument [\"foobar\"]) - [cmd -float 12.34 ](a float option with argument [12.34]) -- [cmd a b c ](three anonymous arguments: ["a"], ["b"], and ["c"]) +- [cmd a b c ](three anonymous arguments: [\"a\"], [\"b\"], and [\"c\"]) - [cmd a b -- c d ](two anonymous arguments and a rest option with two arguments) -*) - -type spec = - | Unit of (unit -> unit) (** Call the function with unit argument *) - | Bool of (bool -> unit) (** Call the function with a bool argument *) - | Set of bool ref (** Set the reference to true *) - | Clear of bool ref (** Set the reference to false *) - | String of (string -> unit) (** Call the function with a string argument *) - | Set_string of string ref (** Set the reference to the string argument *) - | Int of (int -> unit) (** Call the function with an int argument *) - | Set_int of int ref (** Set the reference to the int argument *) - | Float of (float -> unit) (** Call the function with a float argument *) - | Set_float of float ref (** Set the reference to the float argument *) - | Tuple of spec list (** Take several arguments according to the - spec list *) - | Symbol of string list * (string -> unit) - (** Take one of the symbols as argument and - call the function with the symbol *) - | Rest of (string -> unit) (** Stop interpreting keywords and call the - function with each remaining argument *) - | Expand of (string -> string array) (** If the remaining arguments to process +*/ + +/** The concrete type describing the behavior associated + with a keyword. */ +type rec spec = + | /** Call the function with unit argument */ Unit(unit => unit) + | /** Call the function with a bool argument */ Bool(bool => unit) + | /** Set the reference to true */ Set(ref) + | /** Set the reference to false */ Clear(ref) + | /** Call the function with a string argument */ String(string => unit) + | /** Set the reference to the string argument */ Set_string(ref) + | /** Call the function with an int argument */ Int(int => unit) + | /** Set the reference to the int argument */ Set_int(ref) + | /** Call the function with a float argument */ Float(float => unit) + | /** Set the reference to the float argument */ Set_float(ref) + | /** Take several arguments according to the + spec list */ + Tuple(list) + + | /** Take one of the symbols as argument and + call the function with the symbol */ + Symbol(list, string => unit) + + | /** Stop interpreting keywords and call the + function with each remaining argument */ + Rest(string => unit) + + | /** If the remaining arguments to process are of the form - [["-foo"; "arg"] @ rest] where "foo" is + [[\"-foo\"; \"arg\"] @ rest] where \"foo\" is registered as [Expand f], then the - arguments [f "arg" @ rest] are + arguments [f \"arg\" @ rest] are processed. Only allowed in - [parse_and_expand_argv_dynamic]. *) -(** The concrete type describing the behavior associated - with a keyword. *) + [parse_and_expand_argv_dynamic]. */ + Expand(string => array) type key = string type doc = string type usage_msg = string -type anon_fun = (string -> unit) +type anon_fun = string => unit -val parse : - (key * spec * doc) list -> anon_fun -> usage_msg -> unit -(** [Arg.parse speclist anon_fun usage_msg] parses the command line. +/** [Arg.parse speclist anon_fun usage_msg] parses the command line. [speclist] is a list of triples [(key, spec, doc)]. [key] is the option keyword, it must start with a ['-'] character. [spec] gives the option type and the function to call when this option @@ -95,27 +84,25 @@ val parse : list. For the user to be able to specify anonymous arguments starting with a - [-], include for example [("-", String anon_fun, doc)] in [speclist]. + [-], include for example [(\"-\", String anon_fun, doc)] in [speclist]. By default, [parse] recognizes two unit options, [-help] and [--help], which will print to standard output [usage_msg] and the list of options, and exit the program. You can override this behaviour by specifying your own [-help] and [--help] options in [speclist]. -*) +*/ +let parse: (list<(key, spec, doc)>, anon_fun, usage_msg) => unit -val parse_dynamic : - (key * spec * doc) list ref -> anon_fun -> usage_msg -> unit -(** Same as {!Arg.parse}, except that the [speclist] argument is a reference +/** Same as {!Arg.parse}, except that the [speclist] argument is a reference and may be updated during the parsing. A typical use for this feature is to parse command lines of the form: - command subcommand [options] where the list of options depends on the value of the subcommand argument. @since 4.01.0 -*) +*/ +let parse_dynamic: (ref>, anon_fun, usage_msg) => unit -val parse_argv : ?current: int ref -> string array -> - (key * spec * doc) list -> anon_fun -> usage_msg -> unit -(** [Arg.parse_argv ~current args speclist anon_fun usage_msg] parses +/** [Arg.parse_argv ~current args speclist anon_fun usage_msg] parses the array [args] as if it were the command line. It uses and updates the value of [~current] (if given), or {!Arg.current}. You must set it before calling [parse_argv]. The initial value of [current] @@ -124,62 +111,76 @@ val parse_argv : ?current: int ref -> string array -> the error message as argument. If option [-help] or [--help] is given, [Arg.parse_argv] raises {!Arg.Help} with the help message as argument. -*) - -val parse_argv_dynamic : ?current:int ref -> string array -> - (key * spec * doc) list ref -> anon_fun -> string -> unit -(** Same as {!Arg.parse_argv}, except that the [speclist] argument is a +*/ +let parse_argv: ( + ~current: ref=?, + array, + list<(key, spec, doc)>, + anon_fun, + usage_msg, +) => unit + +/** Same as {!Arg.parse_argv}, except that the [speclist] argument is a reference and may be updated during the parsing. See {!Arg.parse_dynamic}. @since 4.01.0 -*) - -val parse_and_expand_argv_dynamic : int ref -> string array ref -> - (key * spec * doc) list ref -> anon_fun -> string -> unit -(** Same as {!Arg.parse_argv_dynamic}, except that the [argv] argument is a +*/ +let parse_argv_dynamic: ( + ~current: ref=?, + array, + ref>, + anon_fun, + string, +) => unit + +/** Same as {!Arg.parse_argv_dynamic}, except that the [argv] argument is a reference and may be updated during the parsing of [Expand] arguments. See {!Arg.parse_argv_dynamic}. @since 4.05.0 -*) - -val parse_expand: - (key * spec * doc) list -> anon_fun -> usage_msg -> unit -(** Same as {!Arg.parse}, except that the [Expand] arguments are allowed and +*/ +let parse_and_expand_argv_dynamic: ( + ref, + ref>, + ref>, + anon_fun, + string, +) => unit + +/** Same as {!Arg.parse}, except that the [Expand] arguments are allowed and the {!current} reference is not updated. @since 4.05.0 -*) +*/ +let parse_expand: (list<(key, spec, doc)>, anon_fun, usage_msg) => unit -exception Help of string -(** Raised by [Arg.parse_argv] when the user asks for help. *) +/** Raised by [Arg.parse_argv] when the user asks for help. */ exception Help(string) -exception Bad of string -(** Functions in [spec] or [anon_fun] can raise [Arg.Bad] with an error +/** Functions in [spec] or [anon_fun] can raise [Arg.Bad] with an error message to reject invalid arguments. - [Arg.Bad] is also raised by {!Arg.parse_argv} in case of an error. *) + [Arg.Bad] is also raised by {!Arg.parse_argv} in case of an error. */ +exception Bad(string) -val usage : (key * spec * doc) list -> usage_msg -> unit -(** [Arg.usage speclist usage_msg] prints to standard error +/** [Arg.usage speclist usage_msg] prints to standard error an error message that includes the list of valid options. This is the same message that {!Arg.parse} prints in case of error. - [speclist] and [usage_msg] are the same as for {!Arg.parse}. *) + [speclist] and [usage_msg] are the same as for {!Arg.parse}. */ +let usage: (list<(key, spec, doc)>, usage_msg) => unit -val usage_string : (key * spec * doc) list -> usage_msg -> string -(** Returns the message that would have been printed by {!Arg.usage}, - if provided with the same parameters. *) +/** Returns the message that would have been printed by {!Arg.usage}, + if provided with the same parameters. */ +let usage_string: (list<(key, spec, doc)>, usage_msg) => string -val align: ?limit: int -> (key * spec * doc) list -> (key * spec * doc) list -(** Align the documentation strings by inserting spaces at the first alignment +/** Align the documentation strings by inserting spaces at the first alignment separator (tab or, if tab is not found, space), according to the length of the keyword. Use a alignment separator as the first character in a doc string if you want to align the whole string. The doc strings corresponding to [Symbol] arguments are aligned on the next line. @param limit options with keyword and message longer than [limit] will not - be used to compute the alignment. *) + be used to compute the alignment. */ +let align: (~limit: int=?, list<(key, spec, doc)>) => list<(key, spec, doc)> -val current : int ref -(** Position (in {!Sys.argv}) of the argument being processed. You can +/** Position (in {!Sys.argv}) of the argument being processed. You can change this value, e.g. to force {!Arg.parse} to skip some arguments. {!Arg.parse} uses the initial value of {!Arg.current} as the index of argument 0 (the program name) and starts parsing arguments - at the next element. *) - + at the next element. */ +let current: ref diff --git a/jscomp/stdlib-406/printexc.ml b/jscomp/stdlib-406/printexc.ml deleted file mode 100644 index 0db4641fa3..0000000000 --- a/jscomp/stdlib-406/printexc.ml +++ /dev/null @@ -1,79 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) -[@@@bs.config { flags = [|"-bs-no-cross-module-opt" |]}] - - -let printers = ref [] - -let locfmt s (linum : int) (start : int) (finish : int) msg = - {j|File "$(s)", line $(linum), characters $(start)-$(finish): $(msg)|j} - - -let fields : exn -> string = [%raw{|function(x){ - var s = "" - var index = 1 - while ("_"+index in x){ - s += x ["_" + index]; - ++ index - } - if(index === 1){ - return s - } - return "(" + s + ")" -} -|}] - - - - - -external exn_slot_name : exn -> string = "?exn_slot_name" - -let to_string x = - let rec conv = function - | hd :: tl -> - (match try hd x with _ -> None with - | Some s -> s - | None -> conv tl) - | [] -> - match x with - | Match_failure(file, line, char) -> - locfmt file line char (char+5) "Pattern matching failed" - | Assert_failure(file, line, char) -> - locfmt file line char (char+6) "Assertion failed" - | Undefined_recursive_module(file, line, char) -> - locfmt file line char (char+6) "Undefined recursive module" - | _ -> - let constructor = - exn_slot_name x in - constructor ^ fields x in - conv !printers - -let print fct arg = - try - fct arg - with x -> - Js.log ("Uncaught exception: " ^ to_string x); - raise x - -let catch fct arg = - try - fct arg - with x -> - Js.log ("Uncaught exception: " ^ to_string x); - exit 2 - -let register_printer fn = - printers := fn :: !printers diff --git a/jscomp/stdlib-406/printexc.mli b/jscomp/stdlib-406/printexc.mli deleted file mode 100644 index 3b5e8a7978..0000000000 --- a/jscomp/stdlib-406/printexc.mli +++ /dev/null @@ -1,57 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) -[@@@ocaml.deprecated "This module is deprecated"] -(** Facilities for printing exceptions and inspecting current call stack. *) - -val to_string: exn -> string -(** [Printexc.to_string e] returns a string representation of - the exception [e]. *) - -val print: ('a -> 'b) -> 'a -> 'b -(** [Printexc.print fn x] applies [fn] to [x] and returns the result. - If the evaluation of [fn x] raises any exception, the - name of the exception is printed on standard error output, - and the exception is raised again. - The typical use is to catch and report exceptions that - escape a function application. *) - -val catch: ('a -> 'b) -> 'a -> 'b -(** [Printexc.catch fn x] is similar to {!Printexc.print}, but - aborts the program with exit code 2 after printing the - uncaught exception. This function is deprecated: the runtime - system is now able to print uncaught exceptions as precisely - as [Printexc.catch] does. Moreover, calling [Printexc.catch] - makes it harder to track the location of the exception - using the debugger or the stack backtrace facility. - So, do not use [Printexc.catch] in new code. *) - -val register_printer: (exn -> string option) -> unit -(** [Printexc.register_printer fn] registers [fn] as an exception - printer. The printer should return [None] or raise an exception - if it does not know how to convert the passed exception, and [Some - s] with [s] the resulting string if it can convert the passed - exception. Exceptions raised by the printer are ignored. - - When converting an exception into a string, the printers will be invoked - in the reverse order of their registrations, until a printer returns - a [Some s] value (if no such printer exists, the runtime will use a - generic printer). - - When using this mechanism, one should be aware that an exception backtrace - is attached to the thread that saw it raised, rather than to the exception - itself. Practically, it means that the code related to [fn] should not use - the backtrace if it has itself raised an exception before. - @since 3.11.2 -*) diff --git a/jscomp/stdlib-406/release.ninja b/jscomp/stdlib-406/release.ninja index 50f835be98..981bc07849 100644 --- a/jscomp/stdlib-406/release.ninja +++ b/jscomp/stdlib-406/release.ninja @@ -12,8 +12,8 @@ o stdlib-406/pervasives.cmj : cc_cmi stdlib-406/pervasives.ml | stdlib-406/perva bsc_flags = $bsc_flags -nopervasives o stdlib-406/pervasives.cmi : cc stdlib-406/pervasives.mli | $bsc others bsc_flags = $bsc_flags -nopervasives -o stdlib-406/arg.cmj : cc_cmi stdlib-406/arg.ml | stdlib-406/arg.cmi stdlib-406/array.cmj stdlib-406/buffer.cmj stdlib-406/list.cmj stdlib-406/string.cmj stdlib-406/sys.cmj $bsc others -o stdlib-406/arg.cmi : cc stdlib-406/arg.mli | stdlib-406/pervasives.cmj $bsc others +o stdlib-406/arg.cmj : cc_cmi stdlib-406/arg.res | stdlib-406/arg.cmi stdlib-406/array.cmj stdlib-406/buffer.cmj stdlib-406/list.cmj stdlib-406/string.cmj stdlib-406/sys.cmj $bsc others +o stdlib-406/arg.cmi : cc stdlib-406/arg.resi | stdlib-406/pervasives.cmj $bsc others o stdlib-406/array.cmj : cc_cmi stdlib-406/array.ml | stdlib-406/array.cmi $bsc others o stdlib-406/array.cmi : cc stdlib-406/array.mli | stdlib-406/pervasives.cmj $bsc others o stdlib-406/arrayLabels.cmj : cc_cmi stdlib-406/arrayLabels.ml | stdlib-406/arrayLabels.cmi $bsc others @@ -64,8 +64,6 @@ o stdlib-406/obj.cmj : cc_cmi stdlib-406/obj.ml | stdlib-406/obj.cmi $bsc others o stdlib-406/obj.cmi : cc stdlib-406/obj.mli | stdlib-406/pervasives.cmj $bsc others o stdlib-406/parsing.cmj : cc_cmi stdlib-406/parsing.ml | stdlib-406/array.cmj stdlib-406/lexing.cmj stdlib-406/obj.cmj stdlib-406/parsing.cmi $bsc others o stdlib-406/parsing.cmi : cc stdlib-406/parsing.mli | stdlib-406/lexing.cmi stdlib-406/obj.cmi stdlib-406/pervasives.cmj $bsc others -o stdlib-406/printexc.cmj : cc_cmi stdlib-406/printexc.ml | stdlib-406/printexc.cmi $bsc others -o stdlib-406/printexc.cmi : cc stdlib-406/printexc.mli | stdlib-406/pervasives.cmj $bsc others o stdlib-406/queue.cmj : cc_cmi stdlib-406/queue.ml | stdlib-406/queue.cmi $bsc others o stdlib-406/queue.cmi : cc stdlib-406/queue.mli | stdlib-406/pervasives.cmj $bsc others o stdlib-406/random.cmj : cc_cmi stdlib-406/random.ml | stdlib-406/array.cmj stdlib-406/char.cmj stdlib-406/digest.cmj stdlib-406/int32.cmj stdlib-406/int64.cmj stdlib-406/pervasives.cmj stdlib-406/random.cmi stdlib-406/string.cmj $bsc others @@ -89,4 +87,4 @@ o stdlib-406/sys.cmj : cc_cmi stdlib-406/sys.ml | stdlib-406/sys.cmi $bsc others o stdlib-406/sys.cmi : cc stdlib-406/sys.mli | stdlib-406/pervasives.cmj $bsc others o stdlib-406/uchar.cmj : cc_cmi stdlib-406/uchar.ml | stdlib-406/char.cmj stdlib-406/pervasives.cmj stdlib-406/uchar.cmi $bsc others o stdlib-406/uchar.cmi : cc stdlib-406/uchar.mli | stdlib-406/pervasives.cmj $bsc others -o $stdlib : phony stdlib-406/pervasives.cmi stdlib-406/pervasives.cmj stdlib-406/arg.cmi stdlib-406/arg.cmj stdlib-406/array.cmi stdlib-406/array.cmj stdlib-406/arrayLabels.cmi stdlib-406/arrayLabels.cmj stdlib-406/buffer.cmi stdlib-406/buffer.cmj stdlib-406/bytes.cmi stdlib-406/bytes.cmj stdlib-406/bytesLabels.cmi stdlib-406/bytesLabels.cmj stdlib-406/callback.cmi stdlib-406/callback.cmj stdlib-406/camlinternalLazy.cmi stdlib-406/camlinternalLazy.cmj stdlib-406/camlinternalMod.cmi stdlib-406/camlinternalMod.cmj stdlib-406/char.cmi stdlib-406/char.cmj stdlib-406/complex.cmi stdlib-406/complex.cmj stdlib-406/digest.cmi stdlib-406/digest.cmj stdlib-406/filename.cmi stdlib-406/filename.cmj stdlib-406/genlex.cmi stdlib-406/genlex.cmj stdlib-406/hashtbl.cmi stdlib-406/hashtbl.cmj stdlib-406/hashtblLabels.cmi stdlib-406/hashtblLabels.cmj stdlib-406/int32.cmi stdlib-406/int32.cmj stdlib-406/int64.cmi stdlib-406/int64.cmj stdlib-406/lazy.cmi stdlib-406/lazy.cmj stdlib-406/lexing.cmi stdlib-406/lexing.cmj stdlib-406/list.cmi stdlib-406/list.cmj stdlib-406/listLabels.cmi stdlib-406/listLabels.cmj stdlib-406/map.cmi stdlib-406/map.cmj stdlib-406/mapLabels.cmi stdlib-406/mapLabels.cmj stdlib-406/moreLabels.cmi stdlib-406/moreLabels.cmj stdlib-406/obj.cmi stdlib-406/obj.cmj stdlib-406/parsing.cmi stdlib-406/parsing.cmj stdlib-406/printexc.cmi stdlib-406/printexc.cmj stdlib-406/queue.cmi stdlib-406/queue.cmj stdlib-406/random.cmi stdlib-406/random.cmj stdlib-406/set.cmi stdlib-406/set.cmj stdlib-406/setLabels.cmi stdlib-406/setLabels.cmj stdlib-406/sort.cmi stdlib-406/sort.cmj stdlib-406/stack.cmi stdlib-406/stack.cmj stdlib-406/stdLabels.cmi stdlib-406/stdLabels.cmj stdlib-406/stream.cmi stdlib-406/stream.cmj stdlib-406/string.cmi stdlib-406/string.cmj stdlib-406/stringLabels.cmi stdlib-406/stringLabels.cmj stdlib-406/sys.cmi stdlib-406/sys.cmj stdlib-406/uchar.cmi stdlib-406/uchar.cmj +o $stdlib : phony stdlib-406/pervasives.cmi stdlib-406/pervasives.cmj stdlib-406/arg.cmi stdlib-406/arg.cmj stdlib-406/array.cmi stdlib-406/array.cmj stdlib-406/arrayLabels.cmi stdlib-406/arrayLabels.cmj stdlib-406/buffer.cmi stdlib-406/buffer.cmj stdlib-406/bytes.cmi stdlib-406/bytes.cmj stdlib-406/bytesLabels.cmi stdlib-406/bytesLabels.cmj stdlib-406/callback.cmi stdlib-406/callback.cmj stdlib-406/camlinternalLazy.cmi stdlib-406/camlinternalLazy.cmj stdlib-406/camlinternalMod.cmi stdlib-406/camlinternalMod.cmj stdlib-406/char.cmi stdlib-406/char.cmj stdlib-406/complex.cmi stdlib-406/complex.cmj stdlib-406/digest.cmi stdlib-406/digest.cmj stdlib-406/filename.cmi stdlib-406/filename.cmj stdlib-406/genlex.cmi stdlib-406/genlex.cmj stdlib-406/hashtbl.cmi stdlib-406/hashtbl.cmj stdlib-406/hashtblLabels.cmi stdlib-406/hashtblLabels.cmj stdlib-406/int32.cmi stdlib-406/int32.cmj stdlib-406/int64.cmi stdlib-406/int64.cmj stdlib-406/lazy.cmi stdlib-406/lazy.cmj stdlib-406/lexing.cmi stdlib-406/lexing.cmj stdlib-406/list.cmi stdlib-406/list.cmj stdlib-406/listLabels.cmi stdlib-406/listLabels.cmj stdlib-406/map.cmi stdlib-406/map.cmj stdlib-406/mapLabels.cmi stdlib-406/mapLabels.cmj stdlib-406/moreLabels.cmi stdlib-406/moreLabels.cmj stdlib-406/obj.cmi stdlib-406/obj.cmj stdlib-406/parsing.cmi stdlib-406/parsing.cmj stdlib-406/queue.cmi stdlib-406/queue.cmj stdlib-406/random.cmi stdlib-406/random.cmj stdlib-406/set.cmi stdlib-406/set.cmj stdlib-406/setLabels.cmi stdlib-406/setLabels.cmj stdlib-406/sort.cmi stdlib-406/sort.cmj stdlib-406/stack.cmi stdlib-406/stack.cmj stdlib-406/stdLabels.cmi stdlib-406/stdLabels.cmj stdlib-406/stream.cmi stdlib-406/stream.cmj stdlib-406/string.cmi stdlib-406/string.cmj stdlib-406/stringLabels.cmi stdlib-406/stringLabels.cmj stdlib-406/sys.cmi stdlib-406/sys.cmj stdlib-406/uchar.cmi stdlib-406/uchar.cmj diff --git a/jscomp/test/build.ninja b/jscomp/test/build.ninja index a7f440ce86..f18a3f8f84 100644 --- a/jscomp/test/build.ninja +++ b/jscomp/test/build.ninja @@ -112,10 +112,10 @@ o test/bs_unwrap_test.cmi test/bs_unwrap_test.cmj : cc test/bs_unwrap_test.ml | o test/buffer_test.cmi test/buffer_test.cmj : cc test/buffer_test.ml | test/mt.cmj $bsc $stdlib runtime o test/bytes_split_gpr_743_test.cmi test/bytes_split_gpr_743_test.cmj : cc test/bytes_split_gpr_743_test.ml | test/mt.cmj $bsc $stdlib runtime o test/caml_compare_test.cmi test/caml_compare_test.cmj : cc test/caml_compare_test.ml | test/mt.cmj $bsc $stdlib runtime -o test/caml_format_test.cmi test/caml_format_test.cmj : cc test/caml_format_test.ml | test/mt.cmj $bsc $stdlib runtime +o test/caml_format_test.cmi test/caml_format_test.cmj : cc test/caml_format_test.res | test/mt.cmj $bsc $stdlib runtime o test/caml_sys_poly_fill_test.cmi test/caml_sys_poly_fill_test.cmj : cc test/caml_sys_poly_fill_test.ml | test/mt.cmj $bsc $stdlib runtime o test/chain_code_test.cmi test/chain_code_test.cmj : cc test/chain_code_test.ml | test/mt.cmj $bsc $stdlib runtime -o test/chn_test.cmi test/chn_test.cmj : cc test/chn_test.ml | test/mt.cmj $bsc $stdlib runtime +o test/chn_test.cmi test/chn_test.cmj : cc test/chn_test.res | test/mt.cmj $bsc $stdlib runtime o test/class_type_ffi_test.cmi test/class_type_ffi_test.cmj : cc test/class_type_ffi_test.ml | $bsc $stdlib runtime o test/coercion_module_alias_test.cmi test/coercion_module_alias_test.cmj : cc test/coercion_module_alias_test.ml | $bsc $stdlib runtime o test/compare_test.cmi test/compare_test.cmj : cc test/compare_test.ml | $bsc $stdlib runtime @@ -170,7 +170,6 @@ o test/exception_def.cmi test/exception_def.cmj : cc test/exception_def.ml | tes o test/exception_raise_test.cmi test/exception_raise_test.cmj : cc test/exception_raise_test.ml | test/mt.cmj $bsc $stdlib runtime o test/exception_rebind_test.cmi test/exception_rebind_test.cmj : cc test/exception_rebind_test.ml | test/exception_def.cmj $bsc $stdlib runtime o test/exception_rebound_err_test.cmi test/exception_rebound_err_test.cmj : cc test/exception_rebound_err_test.ml | test/mt.cmj $bsc $stdlib runtime -o test/exception_repr_test.cmi test/exception_repr_test.cmj : cc test/exception_repr_test.ml | test/exception_def.cmj test/mt.cmj $bsc $stdlib runtime o test/exception_value_test.cmi test/exception_value_test.cmj : cc test/exception_value_test.ml | $bsc $stdlib runtime o test/exn_error_pattern.cmi test/exn_error_pattern.cmj : cc test/exn_error_pattern.ml | test/mt.cmj $bsc $stdlib runtime o test/exponentiation_precedence_test.cmi test/exponentiation_precedence_test.cmj : cc test/exponentiation_precedence_test.res | $bsc $stdlib runtime @@ -238,7 +237,6 @@ o test/gpr_1423_nav.cmi test/gpr_1423_nav.cmj : cc test/gpr_1423_nav.ml | $bsc $ o test/gpr_1438.cmi test/gpr_1438.cmj : cc test/gpr_1438.ml | $bsc $stdlib runtime o test/gpr_1481.cmi test/gpr_1481.cmj : cc test/gpr_1481.ml | $bsc $stdlib runtime o test/gpr_1484.cmi test/gpr_1484.cmj : cc test/gpr_1484.ml | $bsc $stdlib runtime -o test/gpr_1501_test.cmi test/gpr_1501_test.cmj : cc test/gpr_1501_test.ml | test/mt.cmj $bsc $stdlib runtime o test/gpr_1503_test.cmi test/gpr_1503_test.cmj : cc test/gpr_1503_test.ml | test/mt.cmj $bsc $stdlib runtime o test/gpr_1539_test.cmi test/gpr_1539_test.cmj : cc test/gpr_1539_test.ml | $bsc $stdlib runtime o test/gpr_1658_test.cmi test/gpr_1658_test.cmj : cc test/gpr_1658_test.ml | test/mt.cmj $bsc $stdlib runtime @@ -274,7 +272,7 @@ o test/gpr_2700_test.cmi test/gpr_2700_test.cmj : cc test/gpr_2700_test.ml | $bs o test/gpr_2731_test.cmi test/gpr_2731_test.cmj : cc test/gpr_2731_test.ml | $bsc $stdlib runtime o test/gpr_2789_test.cmi test/gpr_2789_test.cmj : cc test/gpr_2789_test.ml | test/mt.cmj $bsc $stdlib runtime o test/gpr_2931_test.cmi test/gpr_2931_test.cmj : cc test/gpr_2931_test.ml | test/mt.cmj $bsc $stdlib runtime -o test/gpr_3142_test.cmi test/gpr_3142_test.cmj : cc test/gpr_3142_test.ml | test/mt.cmj $bsc $stdlib runtime +o test/gpr_3142_test.cmi test/gpr_3142_test.cmj : cc test/gpr_3142_test.res | test/mt.cmj $bsc $stdlib runtime o test/gpr_3154_test.cmi test/gpr_3154_test.cmj : cc test/gpr_3154_test.ml | test/mt.cmj $bsc $stdlib runtime o test/gpr_3209_test.cmi test/gpr_3209_test.cmj : cc test/gpr_3209_test.ml | $bsc $stdlib runtime o test/gpr_3492_test.cmi test/gpr_3492_test.cmj : cc test/gpr_3492_test.ml | test/mt.cmj $bsc $stdlib runtime @@ -356,9 +354,9 @@ o test/include_side_effect_free.cmi test/include_side_effect_free.cmj : cc test/ o test/incomplete_toplevel_test.cmi test/incomplete_toplevel_test.cmj : cc test/incomplete_toplevel_test.ml | $bsc $stdlib runtime o test/infer_type_test.cmj : cc_cmi test/infer_type_test.ml | test/infer_type_test.cmi $bsc $stdlib runtime o test/infer_type_test.cmi : cc test/infer_type_test.mli | $bsc $stdlib runtime -o test/inline_const.cmj : cc_cmi test/inline_const.ml | test/inline_const.cmi $bsc $stdlib runtime -o test/inline_const.cmi : cc test/inline_const.mli | $bsc $stdlib runtime -o test/inline_const_test.cmi test/inline_const_test.cmj : cc test/inline_const_test.ml | test/inline_const.cmj test/mt.cmj $bsc $stdlib runtime +o test/inline_const.cmj : cc_cmi test/inline_const.res | test/inline_const.cmi $bsc $stdlib runtime +o test/inline_const.cmi : cc test/inline_const.resi | $bsc $stdlib runtime +o test/inline_const_test.cmi test/inline_const_test.cmj : cc test/inline_const_test.res | test/inline_const.cmj test/mt.cmj $bsc $stdlib runtime o test/inline_edge_cases.cmj : cc_cmi test/inline_edge_cases.ml | test/inline_edge_cases.cmi $bsc $stdlib runtime o test/inline_edge_cases.cmi : cc test/inline_edge_cases.mli | $bsc $stdlib runtime o test/inline_map2_test.cmi test/inline_map2_test.cmj : cc test/inline_map2_test.ml | test/mt.cmj $bsc $stdlib runtime @@ -433,7 +431,7 @@ o test/loop_suites_test.cmi test/loop_suites_test.cmj : cc test/loop_suites_test o test/map_find_test.cmi test/map_find_test.cmj : cc test/map_find_test.ml | test/mt.cmj $bsc $stdlib runtime o test/map_test.cmj : cc_cmi test/map_test.ml | test/map_test.cmi test/mt.cmj $bsc $stdlib runtime o test/map_test.cmi : cc test/map_test.mli | $bsc $stdlib runtime -o test/mario_game.cmi test/mario_game.cmj : cc test/mario_game.ml | $bsc $stdlib runtime +o test/mario_game.cmi test/mario_game.cmj : cc test/mario_game.res | $bsc $stdlib runtime o test/marshal.cmi test/marshal.cmj : cc test/marshal.ml | $bsc $stdlib runtime o test/meth_annotation.cmi test/meth_annotation.cmj : cc test/meth_annotation.res | $bsc $stdlib runtime o test/method_name_test.cmi test/method_name_test.cmj : cc test/method_name_test.ml | test/mt.cmj $bsc $stdlib runtime @@ -543,8 +541,8 @@ o test/return_check.cmi test/return_check.cmj : cc test/return_check.ml | $bsc $ o test/runtime_encoding_test.cmi test/runtime_encoding_test.cmj : cc test/runtime_encoding_test.ml | $bsc $stdlib runtime o test/set_annotation.cmi test/set_annotation.cmj : cc test/set_annotation.res | $bsc $stdlib runtime o test/set_gen.cmi test/set_gen.cmj : cc test/set_gen.ml | $bsc $stdlib runtime -o test/sexp.cmj : cc_cmi test/sexp.ml | test/sexp.cmi $bsc $stdlib runtime -o test/sexp.cmi : cc test/sexp.mli | $bsc $stdlib runtime +o test/sexp.cmj : cc_cmi test/sexp.res | test/sexp.cmi $bsc $stdlib runtime +o test/sexp.cmi : cc test/sexp.resi | $bsc $stdlib runtime o test/sexpm.cmj : cc_cmi test/sexpm.ml | test/sexpm.cmi $bsc $stdlib runtime o test/sexpm.cmi : cc test/sexpm.mli | $bsc $stdlib runtime o test/sexpm_test.cmi test/sexpm_test.cmj : cc test/sexpm_test.ml | test/mt.cmj test/sexpm.cmj $bsc $stdlib runtime @@ -566,7 +564,6 @@ o test/stream_parser_test.cmi test/stream_parser_test.cmj : cc test/stream_parse o test/string_bound_get_test.cmi test/string_bound_get_test.cmj : cc test/string_bound_get_test.ml | $bsc $stdlib runtime o test/string_constant_compare.cmi test/string_constant_compare.cmj : cc test/string_constant_compare.res | $bsc $stdlib runtime o test/string_get_set_test.cmi test/string_get_set_test.cmj : cc test/string_get_set_test.ml | test/mt.cmj $bsc $stdlib runtime -o test/string_interp_test.cmi test/string_interp_test.cmj : cc test/string_interp_test.ml | $bsc $stdlib runtime o test/string_literal_print_test.cmi test/string_literal_print_test.cmj : cc test/string_literal_print_test.ml | test/mt.cmj $bsc $stdlib runtime o test/string_runtime_test.cmi test/string_runtime_test.cmj : cc test/string_runtime_test.ml | test/mt.cmj test/test_char.cmj $bsc $stdlib runtime o test/string_set.cmi test/string_set.cmj : cc test/string_set.ml | test/set_gen.cmj $bsc $stdlib runtime @@ -726,4 +723,4 @@ o test/utf8_decode_test.cmi test/utf8_decode_test.cmj : cc test/utf8_decode_test o test/variant.cmi test/variant.cmj : cc test/variant.ml | $bsc $stdlib runtime o test/watch_test.cmi test/watch_test.cmj : cc test/watch_test.ml | $bsc $stdlib runtime o test/webpack_config.cmi test/webpack_config.cmj : cc test/webpack_config.ml | $bsc $stdlib runtime -o test : phony test/406_primitive_test.cmi test/406_primitive_test.cmj test/EmptyRecord.cmi test/EmptyRecord.cmj test/SafePromises.cmi test/SafePromises.cmj test/UncurriedExternals.cmi test/UncurriedExternals.cmj test/a.cmi test/a.cmj test/a_filename_test.cmi test/a_filename_test.cmj test/a_list_test.cmi test/a_list_test.cmj test/a_recursive_type.cmi test/a_recursive_type.cmj test/a_scope_bug.cmi test/a_scope_bug.cmj test/a_string_test.cmi test/a_string_test.cmj test/abstract_type.cmi test/abstract_type.cmj test/adt_optimize_test.cmi test/adt_optimize_test.cmj test/alias_default_value_test.cmi test/alias_default_value_test.cmj test/alias_test.cmi test/alias_test.cmj test/and_or_tailcall_test.cmi test/and_or_tailcall_test.cmj test/app_root_finder.cmi test/app_root_finder.cmj test/argv_test.cmi test/argv_test.cmj test/ari_regress_test.cmi test/ari_regress_test.cmj test/arith_lexer.cmi test/arith_lexer.cmj test/arith_parser.cmi test/arith_parser.cmj test/arith_syntax.cmi test/arith_syntax.cmj test/arity.cmi test/arity.cmj test/arity_deopt.cmi test/arity_deopt.cmj test/arity_infer.cmi test/arity_infer.cmj test/array_data_util.cmi test/array_data_util.cmj test/array_safe_get.cmi test/array_safe_get.cmj test/array_subtle_test.cmi test/array_subtle_test.cmj test/array_test.cmi test/array_test.cmj test/ast_abstract_test.cmi test/ast_abstract_test.cmj test/ast_js_mapper_poly_test.cmi test/ast_js_mapper_poly_test.cmj test/ast_js_mapper_test.cmi test/ast_js_mapper_test.cmj test/ast_mapper_defensive_test.cmi test/ast_mapper_defensive_test.cmj test/ast_mapper_unused_warning_test.cmi test/ast_mapper_unused_warning_test.cmj test/async_await.cmi test/async_await.cmj test/async_ideas.cmi test/async_ideas.cmj test/async_inline.cmi test/async_inline.cmj test/attr_test.cmi test/attr_test.cmj test/b.cmi test/b.cmj test/bal_set_mini.cmi test/bal_set_mini.cmj test/bang_primitive.cmi test/bang_primitive.cmj test/basic_module_test.cmi test/basic_module_test.cmj test/bb.cmi test/bb.cmj test/bdd.cmi test/bdd.cmj test/belt_internal_test.cmi test/belt_internal_test.cmj test/belt_result_alias_test.cmi test/belt_result_alias_test.cmj test/bench.cmi test/bench.cmj test/big_enum.cmi test/big_enum.cmj test/big_polyvar_test.cmi test/big_polyvar_test.cmj test/block_alias_test.cmi test/block_alias_test.cmj test/boolean_test.cmi test/boolean_test.cmj test/bs_MapInt_test.cmi test/bs_MapInt_test.cmj test/bs_abstract_test.cmi test/bs_abstract_test.cmj test/bs_array_test.cmi test/bs_array_test.cmj test/bs_auto_uncurry.cmi test/bs_auto_uncurry.cmj test/bs_auto_uncurry_test.cmi test/bs_auto_uncurry_test.cmj test/bs_float_test.cmi test/bs_float_test.cmj test/bs_hashmap_test.cmi test/bs_hashmap_test.cmj test/bs_hashset_int_test.cmi test/bs_hashset_int_test.cmj test/bs_hashtbl_string_test.cmi test/bs_hashtbl_string_test.cmj test/bs_ignore_effect.cmi test/bs_ignore_effect.cmj test/bs_ignore_test.cmi test/bs_ignore_test.cmj test/bs_int_test.cmi test/bs_int_test.cmj test/bs_list_test.cmi test/bs_list_test.cmj test/bs_map_set_dict_test.cmi test/bs_map_set_dict_test.cmj test/bs_map_test.cmi test/bs_map_test.cmj test/bs_min_max_test.cmi test/bs_min_max_test.cmj test/bs_mutable_set_test.cmi test/bs_mutable_set_test.cmj test/bs_node_string_buffer_test.cmi test/bs_node_string_buffer_test.cmj test/bs_poly_map_test.cmi test/bs_poly_map_test.cmj test/bs_poly_mutable_map_test.cmi test/bs_poly_mutable_map_test.cmj test/bs_poly_mutable_set_test.cmi test/bs_poly_mutable_set_test.cmj test/bs_poly_set_test.cmi test/bs_poly_set_test.cmj test/bs_qualified.cmi test/bs_qualified.cmj test/bs_queue_test.cmi test/bs_queue_test.cmj test/bs_rbset_int_bench.cmi test/bs_rbset_int_bench.cmj test/bs_rest_test.cmi test/bs_rest_test.cmj test/bs_set_bench.cmi test/bs_set_bench.cmj test/bs_set_int_test.cmi test/bs_set_int_test.cmj test/bs_sort_test.cmi test/bs_sort_test.cmj test/bs_splice_partial.cmi test/bs_splice_partial.cmj test/bs_stack_test.cmi test/bs_stack_test.cmj test/bs_string_test.cmi test/bs_string_test.cmj test/bs_unwrap_test.cmi test/bs_unwrap_test.cmj test/buffer_test.cmi test/buffer_test.cmj test/bytes_split_gpr_743_test.cmi test/bytes_split_gpr_743_test.cmj test/caml_compare_test.cmi test/caml_compare_test.cmj test/caml_format_test.cmi test/caml_format_test.cmj test/caml_sys_poly_fill_test.cmi test/caml_sys_poly_fill_test.cmj test/chain_code_test.cmi test/chain_code_test.cmj test/chn_test.cmi test/chn_test.cmj test/class_type_ffi_test.cmi test/class_type_ffi_test.cmj test/coercion_module_alias_test.cmi test/coercion_module_alias_test.cmj test/compare_test.cmi test/compare_test.cmj test/complete_parmatch_test.cmi test/complete_parmatch_test.cmj test/complex_if_test.cmi test/complex_if_test.cmj test/complex_test.cmi test/complex_test.cmj test/complex_while_loop.cmi test/complex_while_loop.cmj test/condition_compilation_test.cmi test/condition_compilation_test.cmj test/config1_test.cmi test/config1_test.cmj test/console_log_test.cmi test/console_log_test.cmj test/const_block_test.cmi test/const_block_test.cmj test/const_defs.cmi test/const_defs.cmj test/const_defs_test.cmi test/const_defs_test.cmj test/const_test.cmi test/const_test.cmj test/cont_int_fold_test.cmi test/cont_int_fold_test.cmj test/cps_test.cmi test/cps_test.cmj test/cross_module_inline_test.cmi test/cross_module_inline_test.cmj test/custom_error_test.cmi test/custom_error_test.cmj test/debug_keep_test.cmi test/debug_keep_test.cmj test/debug_mode_value.cmi test/debug_mode_value.cmj test/debug_tmp.cmi test/debug_tmp.cmj test/debugger_test.cmi test/debugger_test.cmj test/default_export_test.cmi test/default_export_test.cmj test/defunctor_make_test.cmi test/defunctor_make_test.cmj test/demo_int_map.cmi test/demo_int_map.cmj test/demo_page.cmi test/demo_page.cmj test/demo_pipe.cmi test/demo_pipe.cmj test/derive_dyntype.cmi test/derive_dyntype.cmj test/derive_projector_test.cmi test/derive_projector_test.cmj test/derive_type_test.cmi test/derive_type_test.cmj test/digest_test.cmi test/digest_test.cmj test/directives.cmi test/directives.cmj test/div_by_zero_test.cmi test/div_by_zero_test.cmj test/dollar_escape_test.cmi test/dollar_escape_test.cmj test/earger_curry_test.cmi test/earger_curry_test.cmj test/effect.cmi test/effect.cmj test/epsilon_test.cmi test/epsilon_test.cmj test/equal_box_test.cmi test/equal_box_test.cmj test/equal_exception_test.cmi test/equal_exception_test.cmj test/equal_test.cmi test/equal_test.cmj test/es6_export.cmi test/es6_export.cmj test/es6_import.cmi test/es6_import.cmj test/es6_module_test.cmi test/es6_module_test.cmj test/escape_esmodule.cmi test/escape_esmodule.cmj test/esmodule_ref.cmi test/esmodule_ref.cmj test/event_ffi.cmi test/event_ffi.cmj test/exception_alias.cmi test/exception_alias.cmj test/exception_def.cmi test/exception_def.cmj test/exception_raise_test.cmi test/exception_raise_test.cmj test/exception_rebind_test.cmi test/exception_rebind_test.cmj test/exception_rebound_err_test.cmi test/exception_rebound_err_test.cmj test/exception_repr_test.cmi test/exception_repr_test.cmj test/exception_value_test.cmi test/exception_value_test.cmj test/exn_error_pattern.cmi test/exn_error_pattern.cmj test/exponentiation_precedence_test.cmi test/exponentiation_precedence_test.cmj test/export_keyword.cmi test/export_keyword.cmj test/ext_array_test.cmi test/ext_array_test.cmj test/ext_bytes_test.cmi test/ext_bytes_test.cmj test/ext_filename_test.cmi test/ext_filename_test.cmj test/ext_list_test.cmi test/ext_list_test.cmj test/ext_pervasives_test.cmi test/ext_pervasives_test.cmj test/ext_string_test.cmi test/ext_string_test.cmj test/ext_sys_test.cmi test/ext_sys_test.cmj test/extensible_variant_test.cmi test/extensible_variant_test.cmj test/external_polyfill_test.cmi test/external_polyfill_test.cmj test/external_ppx.cmi test/external_ppx.cmj test/external_ppx2.cmi test/external_ppx2.cmj test/fail_comp.cmi test/fail_comp.cmj test/ffi_arity_test.cmi test/ffi_arity_test.cmj test/ffi_array_test.cmi test/ffi_array_test.cmj test/ffi_js_test.cmi test/ffi_js_test.cmj test/ffi_splice_test.cmi test/ffi_splice_test.cmj test/ffi_test.cmi test/ffi_test.cmj test/fib.cmi test/fib.cmj test/flattern_order_test.cmi test/flattern_order_test.cmj test/flexible_array_test.cmi test/flexible_array_test.cmj test/float_array.cmi test/float_array.cmj test/float_of_bits_test.cmi test/float_of_bits_test.cmj test/float_record.cmi test/float_record.cmj test/float_test.cmi test/float_test.cmj test/floatarray_test.cmi test/floatarray_test.cmj test/flow_parser_reg_test.cmi test/flow_parser_reg_test.cmj test/for_loop_test.cmi test/for_loop_test.cmj test/for_side_effect_test.cmi test/for_side_effect_test.cmj test/format_regression.cmi test/format_regression.cmj test/format_test.cmi test/format_test.cmj test/fs_test.cmi test/fs_test.cmj test/fun_pattern_match.cmi test/fun_pattern_match.cmj test/functor_app_test.cmi test/functor_app_test.cmj test/functor_def.cmi test/functor_def.cmj test/functor_ffi.cmi test/functor_ffi.cmj test/functor_inst.cmi test/functor_inst.cmj test/functors.cmi test/functors.cmj test/gbk.cmi test/gbk.cmj test/genlex_test.cmi test/genlex_test.cmj test/gentTypeReTest.cmi test/gentTypeReTest.cmj test/global_exception_regression_test.cmi test/global_exception_regression_test.cmj test/global_mangles.cmi test/global_mangles.cmj test/global_module_alias_test.cmi test/global_module_alias_test.cmj test/google_closure_test.cmi test/google_closure_test.cmj test/gpr496_test.cmi test/gpr496_test.cmj test/gpr_1072.cmi test/gpr_1072.cmj test/gpr_1072_reg.cmi test/gpr_1072_reg.cmj test/gpr_1150.cmi test/gpr_1150.cmj test/gpr_1154_test.cmi test/gpr_1154_test.cmj test/gpr_1170.cmi test/gpr_1170.cmj test/gpr_1240_missing_unbox.cmi test/gpr_1240_missing_unbox.cmj test/gpr_1245_test.cmi test/gpr_1245_test.cmj test/gpr_1268.cmi test/gpr_1268.cmj test/gpr_1409_test.cmi test/gpr_1409_test.cmj test/gpr_1423_app_test.cmi test/gpr_1423_app_test.cmj test/gpr_1423_nav.cmi test/gpr_1423_nav.cmj test/gpr_1438.cmi test/gpr_1438.cmj test/gpr_1481.cmi test/gpr_1481.cmj test/gpr_1484.cmi test/gpr_1484.cmj test/gpr_1501_test.cmi test/gpr_1501_test.cmj test/gpr_1503_test.cmi test/gpr_1503_test.cmj test/gpr_1539_test.cmi test/gpr_1539_test.cmj test/gpr_1658_test.cmi test/gpr_1658_test.cmj test/gpr_1667_test.cmi test/gpr_1667_test.cmj test/gpr_1692_test.cmi test/gpr_1692_test.cmj test/gpr_1698_test.cmi test/gpr_1698_test.cmj test/gpr_1701_test.cmi test/gpr_1701_test.cmj test/gpr_1716_test.cmi test/gpr_1716_test.cmj test/gpr_1717_test.cmi test/gpr_1717_test.cmj test/gpr_1728_test.cmi test/gpr_1728_test.cmj test/gpr_1749_test.cmi test/gpr_1749_test.cmj test/gpr_1759_test.cmi test/gpr_1759_test.cmj test/gpr_1760_test.cmi test/gpr_1760_test.cmj test/gpr_1762_test.cmi test/gpr_1762_test.cmj test/gpr_1817_test.cmi test/gpr_1817_test.cmj test/gpr_1822_test.cmi test/gpr_1822_test.cmj test/gpr_1891_test.cmi test/gpr_1891_test.cmj test/gpr_1943_test.cmi test/gpr_1943_test.cmj test/gpr_1946_test.cmi test/gpr_1946_test.cmj test/gpr_2316_test.cmi test/gpr_2316_test.cmj test/gpr_2352_test.cmi test/gpr_2352_test.cmj test/gpr_2413_test.cmi test/gpr_2413_test.cmj test/gpr_2474.cmi test/gpr_2474.cmj test/gpr_2487.cmi test/gpr_2487.cmj test/gpr_2503_test.cmi test/gpr_2503_test.cmj test/gpr_2608_test.cmi test/gpr_2608_test.cmj test/gpr_2614_test.cmi test/gpr_2614_test.cmj test/gpr_2633_test.cmi test/gpr_2633_test.cmj test/gpr_2642_test.cmi test/gpr_2642_test.cmj test/gpr_2652_test.cmi test/gpr_2652_test.cmj test/gpr_2682_test.cmi test/gpr_2682_test.cmj test/gpr_2700_test.cmi test/gpr_2700_test.cmj test/gpr_2731_test.cmi test/gpr_2731_test.cmj test/gpr_2789_test.cmi test/gpr_2789_test.cmj test/gpr_2931_test.cmi test/gpr_2931_test.cmj test/gpr_3142_test.cmi test/gpr_3142_test.cmj test/gpr_3154_test.cmi test/gpr_3154_test.cmj test/gpr_3209_test.cmi test/gpr_3209_test.cmj test/gpr_3492_test.cmi test/gpr_3492_test.cmj test/gpr_3519_jsx_test.cmi test/gpr_3519_jsx_test.cmj test/gpr_3519_test.cmi test/gpr_3519_test.cmj test/gpr_3536_test.cmi test/gpr_3536_test.cmj test/gpr_3546_test.cmi test/gpr_3546_test.cmj test/gpr_3548_test.cmi test/gpr_3548_test.cmj test/gpr_3549_test.cmi test/gpr_3549_test.cmj test/gpr_3566_drive_test.cmi test/gpr_3566_drive_test.cmj test/gpr_3566_test.cmi test/gpr_3566_test.cmj test/gpr_3595_test.cmi test/gpr_3595_test.cmj test/gpr_3609_test.cmi test/gpr_3609_test.cmj test/gpr_3697_test.cmi test/gpr_3697_test.cmj test/gpr_373_test.cmi test/gpr_373_test.cmj test/gpr_3770_test.cmi test/gpr_3770_test.cmj test/gpr_3852_alias.cmi test/gpr_3852_alias.cmj test/gpr_3852_alias_reify.cmi test/gpr_3852_alias_reify.cmj test/gpr_3852_effect.cmi test/gpr_3852_effect.cmj test/gpr_3865.cmi test/gpr_3865.cmj test/gpr_3865_bar.cmi test/gpr_3865_bar.cmj test/gpr_3865_foo.cmi test/gpr_3865_foo.cmj test/gpr_3875_test.cmi test/gpr_3875_test.cmj test/gpr_3877_test.cmi test/gpr_3877_test.cmj test/gpr_3895_test.cmi test/gpr_3895_test.cmj test/gpr_3897_test.cmi test/gpr_3897_test.cmj test/gpr_3931_test.cmi test/gpr_3931_test.cmj test/gpr_3980_test.cmi test/gpr_3980_test.cmj test/gpr_4025_test.cmi test/gpr_4025_test.cmj test/gpr_405_test.cmi test/gpr_405_test.cmj test/gpr_4069_test.cmi test/gpr_4069_test.cmj test/gpr_4265_test.cmi test/gpr_4265_test.cmj test/gpr_4274_test.cmi test/gpr_4274_test.cmj test/gpr_4280_test.cmi test/gpr_4280_test.cmj test/gpr_4407_test.cmi test/gpr_4407_test.cmj test/gpr_441.cmi test/gpr_441.cmj test/gpr_4442_test.cmi test/gpr_4442_test.cmj test/gpr_4491_test.cmi test/gpr_4491_test.cmj test/gpr_4494_test.cmi test/gpr_4494_test.cmj test/gpr_4519_test.cmi test/gpr_4519_test.cmj test/gpr_459_test.cmi test/gpr_459_test.cmj test/gpr_4632.cmi test/gpr_4632.cmj test/gpr_4639_test.cmi test/gpr_4639_test.cmj test/gpr_4900_test.cmi test/gpr_4900_test.cmj test/gpr_4924_test.cmi test/gpr_4924_test.cmj test/gpr_4931.cmi test/gpr_4931.cmj test/gpr_4931_allow.cmi test/gpr_4931_allow.cmj test/gpr_5071_test.cmi test/gpr_5071_test.cmj test/gpr_5169_test.cmi test/gpr_5169_test.cmj test/gpr_5218_test.cmi test/gpr_5218_test.cmj test/gpr_5280_optimize_test.cmi test/gpr_5280_optimize_test.cmj test/gpr_5312.cmi test/gpr_5312.cmj test/gpr_5557.cmi test/gpr_5557.cmj test/gpr_5753.cmi test/gpr_5753.cmj test/gpr_658.cmi test/gpr_658.cmj test/gpr_858_test.cmi test/gpr_858_test.cmj test/gpr_858_unit2_test.cmi test/gpr_858_unit2_test.cmj test/gpr_904_test.cmi test/gpr_904_test.cmj test/gpr_974_test.cmi test/gpr_974_test.cmj test/gpr_977_test.cmi test/gpr_977_test.cmj test/gpr_return_type_unused_attribute.cmi test/gpr_return_type_unused_attribute.cmj test/gray_code_test.cmi test/gray_code_test.cmj test/guide_for_ext.cmi test/guide_for_ext.cmj test/hamming_test.cmi test/hamming_test.cmj test/hash_collision_test.cmi test/hash_collision_test.cmj test/hash_sugar_desugar.cmi test/hash_sugar_desugar.cmj test/hash_test.cmi test/hash_test.cmj test/hashtbl_test.cmi test/hashtbl_test.cmj test/hello.foo.cmi test/hello.foo.cmj test/hello_res.cmi test/hello_res.cmj test/ignore_test.cmi test/ignore_test.cmj test/imm_map_bench.cmi test/imm_map_bench.cmj test/include_side_effect.cmi test/include_side_effect.cmj test/include_side_effect_free.cmi test/include_side_effect_free.cmj test/incomplete_toplevel_test.cmi test/incomplete_toplevel_test.cmj test/infer_type_test.cmi test/infer_type_test.cmj test/inline_const.cmi test/inline_const.cmj test/inline_const_test.cmi test/inline_const_test.cmj test/inline_edge_cases.cmi test/inline_edge_cases.cmj test/inline_map2_test.cmi test/inline_map2_test.cmj test/inline_map_demo.cmi test/inline_map_demo.cmj test/inline_map_test.cmi test/inline_map_test.cmj test/inline_record_test.cmi test/inline_record_test.cmj test/inline_regression_test.cmi test/inline_regression_test.cmj test/inline_string_test.cmi test/inline_string_test.cmj test/inner_call.cmi test/inner_call.cmj test/inner_define.cmi test/inner_define.cmj test/inner_unused.cmi test/inner_unused.cmj test/installation_test.cmi test/installation_test.cmj test/int32_test.cmi test/int32_test.cmj test/int64_mul_div_test.cmi test/int64_mul_div_test.cmj test/int64_string_bench.cmi test/int64_string_bench.cmj test/int64_string_test.cmi test/int64_string_test.cmj test/int64_test.cmi test/int64_test.cmj test/int_hashtbl_test.cmi test/int_hashtbl_test.cmj test/int_map.cmi test/int_map.cmj test/int_overflow_test.cmi test/int_overflow_test.cmj test/int_poly_var.cmi test/int_poly_var.cmj test/int_switch_test.cmi test/int_switch_test.cmj test/internal_unused_test.cmi test/internal_unused_test.cmj test/io_test.cmi test/io_test.cmj test/js_array_test.cmi test/js_array_test.cmj test/js_bool_test.cmi test/js_bool_test.cmj test/js_cast_test.cmi test/js_cast_test.cmj test/js_date_test.cmi test/js_date_test.cmj test/js_dict_test.cmi test/js_dict_test.cmj test/js_exception_catch_test.cmi test/js_exception_catch_test.cmj test/js_float_test.cmi test/js_float_test.cmj test/js_global_test.cmi test/js_global_test.cmj test/js_int_test.cmi test/js_int_test.cmj test/js_json_test.cmi test/js_json_test.cmj test/js_list_test.cmi test/js_list_test.cmj test/js_math_test.cmi test/js_math_test.cmj test/js_null_test.cmi test/js_null_test.cmj test/js_null_undefined_test.cmi test/js_null_undefined_test.cmj test/js_nullable_test.cmi test/js_nullable_test.cmj test/js_obj_test.cmi test/js_obj_test.cmj test/js_option_test.cmi test/js_option_test.cmj test/js_promise_basic_test.cmi test/js_promise_basic_test.cmj test/js_re_test.cmi test/js_re_test.cmj test/js_string_test.cmi test/js_string_test.cmj test/js_typed_array_test.cmi test/js_typed_array_test.cmj test/js_undefined_test.cmi test/js_undefined_test.cmj test/js_val.cmi test/js_val.cmj test/jsoo_400_test.cmi test/jsoo_400_test.cmj test/jsoo_485_test.cmi test/jsoo_485_test.cmj test/jsxv4_newtype.cmi test/jsxv4_newtype.cmj test/key_word_property.cmi test/key_word_property.cmj test/key_word_property2.cmi test/key_word_property2.cmj test/key_word_property_plus_test.cmi test/key_word_property_plus_test.cmj test/label_uncurry.cmi test/label_uncurry.cmj test/large_integer_pat.cmi test/large_integer_pat.cmj test/large_record_duplication_test.cmi test/large_record_duplication_test.cmj test/largest_int_flow.cmi test/largest_int_flow.cmj test/lazy_demo.cmi test/lazy_demo.cmj test/lazy_test.cmi test/lazy_test.cmj test/lexer_test.cmi test/lexer_test.cmj test/lib_js_test.cmi test/lib_js_test.cmj test/libarg_test.cmi test/libarg_test.cmj test/libqueue_test.cmi test/libqueue_test.cmj test/limits_test.cmi test/limits_test.cmj test/list_stack.cmi test/list_stack.cmj test/list_test.cmi test/list_test.cmj test/local_exception_test.cmi test/local_exception_test.cmj test/loop_regression_test.cmi test/loop_regression_test.cmj test/loop_suites_test.cmi test/loop_suites_test.cmj test/map_find_test.cmi test/map_find_test.cmj test/map_test.cmi test/map_test.cmj test/mario_game.cmi test/mario_game.cmj test/marshal.cmi test/marshal.cmj test/meth_annotation.cmi test/meth_annotation.cmj test/method_name_test.cmi test/method_name_test.cmj test/method_string_name.cmi test/method_string_name.cmj test/minimal_test.cmi test/minimal_test.cmj test/miss_colon_test.cmi test/miss_colon_test.cmj test/mock_mt.cmi test/mock_mt.cmj test/module_alias_test.cmi test/module_alias_test.cmj test/module_as_class_ffi.cmi test/module_as_class_ffi.cmj test/module_as_function.cmi test/module_as_function.cmj test/module_missing_conversion.cmi test/module_missing_conversion.cmj test/module_parameter_test.cmi test/module_parameter_test.cmj test/module_splice_test.cmi test/module_splice_test.cmj test/more_poly_variant_test.cmi test/more_poly_variant_test.cmj test/more_uncurry.cmi test/more_uncurry.cmj test/mpr_6033_test.cmi test/mpr_6033_test.cmj test/mt.cmi test/mt.cmj test/mt_global.cmi test/mt_global.cmj test/mutable_obj_test.cmi test/mutable_obj_test.cmj test/mutable_uncurry_test.cmi test/mutable_uncurry_test.cmj test/mutual_non_recursive_type.cmi test/mutual_non_recursive_type.cmj test/name_mangle_test.cmi test/name_mangle_test.cmj test/nested_include.cmi test/nested_include.cmj test/nested_module_alias.cmi test/nested_module_alias.cmj test/nested_obj_literal.cmi test/nested_obj_literal.cmj test/nested_obj_test.cmi test/nested_obj_test.cmj test/nested_pattern_match_test.cmi test/nested_pattern_match_test.cmj test/noassert.cmi test/noassert.cmj test/node_fs_test.cmi test/node_fs_test.cmj test/node_path_test.cmi test/node_path_test.cmj test/null_list_test.cmi test/null_list_test.cmj test/number_lexer.cmi test/number_lexer.cmj test/obj_literal_ppx.cmi test/obj_literal_ppx.cmj test/obj_literal_ppx_test.cmi test/obj_literal_ppx_test.cmj test/obj_magic_test.cmi test/obj_magic_test.cmj test/obj_type_test.cmi test/obj_type_test.cmj test/ocaml_re_test.cmi test/ocaml_re_test.cmj test/of_string_test.cmi test/of_string_test.cmj test/offset.cmi test/offset.cmj test/option_encoding_test.cmi test/option_encoding_test.cmj test/option_record_none_test.cmi test/option_record_none_test.cmj test/option_repr_test.cmi test/option_repr_test.cmj test/optional_ffi_test.cmi test/optional_ffi_test.cmj test/optional_regression_test.cmi test/optional_regression_test.cmj test/pipe_send_readline.cmi test/pipe_send_readline.cmj test/pipe_syntax.cmi test/pipe_syntax.cmj test/poly_empty_array.cmi test/poly_empty_array.cmj test/poly_variant_test.cmi test/poly_variant_test.cmj test/polymorphic_raw_test.cmi test/polymorphic_raw_test.cmj test/polymorphism_test.cmi test/polymorphism_test.cmj test/polyvar_convert.cmi test/polyvar_convert.cmj test/polyvar_test.cmi test/polyvar_test.cmj test/ppx_apply_test.cmi test/ppx_apply_test.cmj test/pq_test.cmi test/pq_test.cmj test/pr6726.cmi test/pr6726.cmj test/pr_regression_test.cmi test/pr_regression_test.cmj test/prepend_data_ffi.cmi test/prepend_data_ffi.cmj test/primitive_reg_test.cmi test/primitive_reg_test.cmj test/print_alpha_test.cmi test/print_alpha_test.cmj test/promise_catch_test.cmi test/promise_catch_test.cmj test/queue_402.cmi test/queue_402.cmj test/queue_test.cmi test/queue_test.cmj test/random_test.cmi test/random_test.cmj test/raw_hash_tbl_bench.cmi test/raw_hash_tbl_bench.cmj test/raw_output_test.cmi test/raw_output_test.cmj test/raw_pure_test.cmi test/raw_pure_test.cmj test/rbset.cmi test/rbset.cmj test/react.cmi test/react.cmj test/reactDOMRe.cmi test/reactDOMRe.cmj test/reactDOMServerRe.cmi test/reactDOMServerRe.cmj test/reactEvent.cmi test/reactEvent.cmj test/reactTestUtils.cmi test/reactTestUtils.cmj test/reasonReact.cmi test/reasonReact.cmj test/reasonReactCompat.cmi test/reasonReactCompat.cmj test/reasonReactOptimizedCreateClass.cmi test/reasonReactOptimizedCreateClass.cmj test/reasonReactRouter.cmi test/reasonReactRouter.cmj test/rebind_module.cmi test/rebind_module.cmj test/rebind_module_test.cmi test/rebind_module_test.cmj test/rec_array_test.cmi test/rec_array_test.cmj test/rec_fun_test.cmi test/rec_fun_test.cmj test/rec_module_opt.cmi test/rec_module_opt.cmj test/rec_module_test.cmi test/rec_module_test.cmj test/rec_value_test.cmi test/rec_value_test.cmj test/record_debug_test.cmi test/record_debug_test.cmj test/record_extension_test.cmi test/record_extension_test.cmj test/record_name_test.cmi test/record_name_test.cmj test/record_regression.cmi test/record_regression.cmj test/record_with_test.cmi test/record_with_test.cmj test/recursive_module.cmi test/recursive_module.cmj test/recursive_module_test.cmi test/recursive_module_test.cmj test/recursive_react_component.cmi test/recursive_react_component.cmj test/recursive_records_test.cmi test/recursive_records_test.cmj test/recursive_unbound_module_test.cmi test/recursive_unbound_module_test.cmj test/regression_print.cmi test/regression_print.cmj test/relative_path.cmi test/relative_path.cmj test/res_debug.cmi test/res_debug.cmj test/return_check.cmi test/return_check.cmj test/runtime_encoding_test.cmi test/runtime_encoding_test.cmj test/set_annotation.cmi test/set_annotation.cmj test/set_gen.cmi test/set_gen.cmj test/sexp.cmi test/sexp.cmj test/sexpm.cmi test/sexpm.cmj test/sexpm_test.cmi test/sexpm_test.cmj test/side_effect.cmi test/side_effect.cmj test/side_effect_free.cmi test/side_effect_free.cmj test/simple_derive_test.cmi test/simple_derive_test.cmj test/simple_derive_use.cmi test/simple_derive_use.cmj test/simple_lexer_test.cmi test/simple_lexer_test.cmj test/simplify_lambda_632o.cmi test/simplify_lambda_632o.cmj test/single_module_alias.cmi test/single_module_alias.cmj test/singular_unit_test.cmi test/singular_unit_test.cmj test/small_inline_test.cmi test/small_inline_test.cmj test/splice_test.cmi test/splice_test.cmj test/stack_comp_test.cmi test/stack_comp_test.cmj test/stack_test.cmi test/stack_test.cmj test/stream_parser_test.cmi test/stream_parser_test.cmj test/string_bound_get_test.cmi test/string_bound_get_test.cmj test/string_constant_compare.cmi test/string_constant_compare.cmj test/string_get_set_test.cmi test/string_get_set_test.cmj test/string_interp_test.cmi test/string_interp_test.cmj test/string_literal_print_test.cmi test/string_literal_print_test.cmj test/string_runtime_test.cmi test/string_runtime_test.cmj test/string_set.cmi test/string_set.cmj test/string_set_test.cmi test/string_set_test.cmj test/string_test.cmi test/string_test.cmj test/string_unicode_test.cmi test/string_unicode_test.cmj test/stringmatch_test.cmi test/stringmatch_test.cmj test/submodule.cmi test/submodule.cmj test/submodule_call.cmi test/submodule_call.cmj test/switch_case_test.cmi test/switch_case_test.cmj test/switch_string.cmi test/switch_string.cmj test/tailcall_inline_test.cmi test/tailcall_inline_test.cmj test/template.cmi test/template.cmj test/test.cmi test/test.cmj test/test2.cmi test/test2.cmj test/test_alias.cmi test/test_alias.cmj test/test_ari.cmi test/test_ari.cmj test/test_array.cmi test/test_array.cmj test/test_array_append.cmi test/test_array_append.cmj test/test_array_primitive.cmi test/test_array_primitive.cmj test/test_bool_equal.cmi test/test_bool_equal.cmj test/test_bs_this.cmi test/test_bs_this.cmj test/test_bug.cmi test/test_bug.cmj test/test_bytes.cmi test/test_bytes.cmj test/test_case_opt_collision.cmi test/test_case_opt_collision.cmj test/test_case_set.cmi test/test_case_set.cmj test/test_char.cmi test/test_char.cmj test/test_closure.cmi test/test_closure.cmj test/test_common.cmi test/test_common.cmj test/test_const_elim.cmi test/test_const_elim.cmj test/test_const_propogate.cmi test/test_const_propogate.cmj test/test_cpp.cmi test/test_cpp.cmj test/test_cps.cmi test/test_cps.cmj test/test_demo.cmi test/test_demo.cmj test/test_dup_param.cmi test/test_dup_param.cmj test/test_eq.cmi test/test_eq.cmj test/test_exception.cmi test/test_exception.cmj test/test_exception_escape.cmi test/test_exception_escape.cmj test/test_export2.cmi test/test_export2.cmj test/test_external.cmi test/test_external.cmj test/test_external_unit.cmi test/test_external_unit.cmj test/test_ffi.cmi test/test_ffi.cmj test/test_fib.cmi test/test_fib.cmj test/test_filename.cmi test/test_filename.cmj test/test_for_loop.cmi test/test_for_loop.cmj test/test_for_map.cmi test/test_for_map.cmj test/test_for_map2.cmi test/test_for_map2.cmj test/test_format.cmi test/test_format.cmj test/test_formatter.cmi test/test_formatter.cmj test/test_functor_dead_code.cmi test/test_functor_dead_code.cmj test/test_generative_module.cmi test/test_generative_module.cmj test/test_global_print.cmi test/test_global_print.cmj test/test_google_closure.cmi test/test_google_closure.cmj test/test_include.cmi test/test_include.cmj test/test_incomplete.cmi test/test_incomplete.cmj test/test_incr_ref.cmi test/test_incr_ref.cmj test/test_int_map_find.cmi test/test_int_map_find.cmj test/test_internalOO.cmi test/test_internalOO.cmj test/test_is_js.cmi test/test_is_js.cmj test/test_js_ffi.cmi test/test_js_ffi.cmj test/test_let.cmi test/test_let.cmj test/test_list.cmi test/test_list.cmj test/test_literal.cmi test/test_literal.cmj test/test_literals.cmi test/test_literals.cmj test/test_match_exception.cmi test/test_match_exception.cmj test/test_mutliple.cmi test/test_mutliple.cmj test/test_nat64.cmi test/test_nat64.cmj test/test_nested_let.cmi test/test_nested_let.cmj test/test_nested_print.cmi test/test_nested_print.cmj test/test_non_export.cmi test/test_non_export.cmj test/test_nullary.cmi test/test_nullary.cmj test/test_obj.cmi test/test_obj.cmj test/test_obj_simple_ffi.cmi test/test_obj_simple_ffi.cmj test/test_order.cmi test/test_order.cmj test/test_order_tailcall.cmi test/test_order_tailcall.cmj test/test_other_exn.cmi test/test_other_exn.cmj test/test_pack.cmi test/test_pack.cmj test/test_per.cmi test/test_per.cmj test/test_pervasive.cmi test/test_pervasive.cmj test/test_pervasives2.cmi test/test_pervasives2.cmj test/test_pervasives3.cmi test/test_pervasives3.cmj test/test_primitive.cmi test/test_primitive.cmj test/test_ramification.cmi test/test_ramification.cmj test/test_react.cmi test/test_react.cmj test/test_react_case.cmi test/test_react_case.cmj test/test_regex.cmi test/test_regex.cmj test/test_require.cmi test/test_require.cmj test/test_runtime_encoding.cmi test/test_runtime_encoding.cmj test/test_scope.cmi test/test_scope.cmj test/test_seq.cmi test/test_seq.cmj test/test_set.cmi test/test_set.cmj test/test_side_effect_functor.cmi test/test_side_effect_functor.cmj test/test_simple_include.cmi test/test_simple_include.cmj test/test_simple_pattern_match.cmi test/test_simple_pattern_match.cmj test/test_simple_ref.cmi test/test_simple_ref.cmj test/test_simple_tailcall.cmi test/test_simple_tailcall.cmj test/test_small.cmi test/test_small.cmj test/test_sprintf.cmi test/test_sprintf.cmj test/test_stack.cmi test/test_stack.cmj test/test_static_catch_ident.cmi test/test_static_catch_ident.cmj test/test_string.cmi test/test_string.cmj test/test_string_case.cmi test/test_string_case.cmj test/test_string_const.cmi test/test_string_const.cmj test/test_string_map.cmi test/test_string_map.cmj test/test_string_switch.cmi test/test_string_switch.cmj test/test_switch.cmi test/test_switch.cmj test/test_trywith.cmi test/test_trywith.cmj test/test_tuple.cmi test/test_tuple.cmj test/test_tuple_destructring.cmi test/test_tuple_destructring.cmj test/test_type_based_arity.cmi test/test_type_based_arity.cmj test/test_u.cmi test/test_u.cmj test/test_unknown.cmi test/test_unknown.cmj test/test_unsafe_cmp.cmi test/test_unsafe_cmp.cmj test/test_unsafe_obj_ffi.cmi test/test_unsafe_obj_ffi.cmj test/test_unsafe_obj_ffi_ppx.cmi test/test_unsafe_obj_ffi_ppx.cmj test/test_unsupported_primitive.cmi test/test_unsupported_primitive.cmj test/test_while_closure.cmi test/test_while_closure.cmj test/test_while_side_effect.cmi test/test_while_side_effect.cmj test/test_zero_nullable.cmi test/test_zero_nullable.cmj test/then_mangle_test.cmi test/then_mangle_test.cmj test/ticker.cmi test/ticker.cmj test/to_string_test.cmi test/to_string_test.cmj test/topsort_test.cmi test/topsort_test.cmj test/tramp_fib.cmi test/tramp_fib.cmj test/tuple_alloc.cmi test/tuple_alloc.cmj test/type_disambiguate.cmi test/type_disambiguate.cmj test/typeof_test.cmi test/typeof_test.cmj test/ui_defs.cmi test/unboxed_attribute.cmi test/unboxed_attribute.cmj test/unboxed_attribute_test.cmi test/unboxed_attribute_test.cmj test/unboxed_crash.cmi test/unboxed_crash.cmj test/unboxed_use_case.cmi test/unboxed_use_case.cmj test/uncurried_cast.cmi test/uncurried_cast.cmj test/uncurried_default.args.cmi test/uncurried_default.args.cmj test/uncurried_pipe.cmi test/uncurried_pipe.cmj test/uncurry_external_test.cmi test/uncurry_external_test.cmj test/uncurry_glob_test.cmi test/uncurry_glob_test.cmj test/uncurry_test.cmi test/uncurry_test.cmj test/undef_regression2_test.cmi test/undef_regression2_test.cmj test/undef_regression_test.cmi test/undef_regression_test.cmj test/undefine_conditional.cmi test/undefine_conditional.cmj test/unicode_type_error.cmi test/unicode_type_error.cmj test/unit_undefined_test.cmi test/unit_undefined_test.cmj test/unitest_string.cmi test/unitest_string.cmj test/unsafe_full_apply_primitive.cmi test/unsafe_full_apply_primitive.cmj test/unsafe_ppx_test.cmi test/unsafe_ppx_test.cmj test/unsafe_this.cmi test/unsafe_this.cmj test/update_record_test.cmi test/update_record_test.cmj test/utf8_decode_test.cmi test/utf8_decode_test.cmj test/variant.cmi test/variant.cmj test/watch_test.cmi test/watch_test.cmj test/webpack_config.cmi test/webpack_config.cmj +o test : phony test/406_primitive_test.cmi test/406_primitive_test.cmj test/EmptyRecord.cmi test/EmptyRecord.cmj test/SafePromises.cmi test/SafePromises.cmj test/UncurriedExternals.cmi test/UncurriedExternals.cmj test/a.cmi test/a.cmj test/a_filename_test.cmi test/a_filename_test.cmj test/a_list_test.cmi test/a_list_test.cmj test/a_recursive_type.cmi test/a_recursive_type.cmj test/a_scope_bug.cmi test/a_scope_bug.cmj test/a_string_test.cmi test/a_string_test.cmj test/abstract_type.cmi test/abstract_type.cmj test/adt_optimize_test.cmi test/adt_optimize_test.cmj test/alias_default_value_test.cmi test/alias_default_value_test.cmj test/alias_test.cmi test/alias_test.cmj test/and_or_tailcall_test.cmi test/and_or_tailcall_test.cmj test/app_root_finder.cmi test/app_root_finder.cmj test/argv_test.cmi test/argv_test.cmj test/ari_regress_test.cmi test/ari_regress_test.cmj test/arith_lexer.cmi test/arith_lexer.cmj test/arith_parser.cmi test/arith_parser.cmj test/arith_syntax.cmi test/arith_syntax.cmj test/arity.cmi test/arity.cmj test/arity_deopt.cmi test/arity_deopt.cmj test/arity_infer.cmi test/arity_infer.cmj test/array_data_util.cmi test/array_data_util.cmj test/array_safe_get.cmi test/array_safe_get.cmj test/array_subtle_test.cmi test/array_subtle_test.cmj test/array_test.cmi test/array_test.cmj test/ast_abstract_test.cmi test/ast_abstract_test.cmj test/ast_js_mapper_poly_test.cmi test/ast_js_mapper_poly_test.cmj test/ast_js_mapper_test.cmi test/ast_js_mapper_test.cmj test/ast_mapper_defensive_test.cmi test/ast_mapper_defensive_test.cmj test/ast_mapper_unused_warning_test.cmi test/ast_mapper_unused_warning_test.cmj test/async_await.cmi test/async_await.cmj test/async_ideas.cmi test/async_ideas.cmj test/async_inline.cmi test/async_inline.cmj test/attr_test.cmi test/attr_test.cmj test/b.cmi test/b.cmj test/bal_set_mini.cmi test/bal_set_mini.cmj test/bang_primitive.cmi test/bang_primitive.cmj test/basic_module_test.cmi test/basic_module_test.cmj test/bb.cmi test/bb.cmj test/bdd.cmi test/bdd.cmj test/belt_internal_test.cmi test/belt_internal_test.cmj test/belt_result_alias_test.cmi test/belt_result_alias_test.cmj test/bench.cmi test/bench.cmj test/big_enum.cmi test/big_enum.cmj test/big_polyvar_test.cmi test/big_polyvar_test.cmj test/block_alias_test.cmi test/block_alias_test.cmj test/boolean_test.cmi test/boolean_test.cmj test/bs_MapInt_test.cmi test/bs_MapInt_test.cmj test/bs_abstract_test.cmi test/bs_abstract_test.cmj test/bs_array_test.cmi test/bs_array_test.cmj test/bs_auto_uncurry.cmi test/bs_auto_uncurry.cmj test/bs_auto_uncurry_test.cmi test/bs_auto_uncurry_test.cmj test/bs_float_test.cmi test/bs_float_test.cmj test/bs_hashmap_test.cmi test/bs_hashmap_test.cmj test/bs_hashset_int_test.cmi test/bs_hashset_int_test.cmj test/bs_hashtbl_string_test.cmi test/bs_hashtbl_string_test.cmj test/bs_ignore_effect.cmi test/bs_ignore_effect.cmj test/bs_ignore_test.cmi test/bs_ignore_test.cmj test/bs_int_test.cmi test/bs_int_test.cmj test/bs_list_test.cmi test/bs_list_test.cmj test/bs_map_set_dict_test.cmi test/bs_map_set_dict_test.cmj test/bs_map_test.cmi test/bs_map_test.cmj test/bs_min_max_test.cmi test/bs_min_max_test.cmj test/bs_mutable_set_test.cmi test/bs_mutable_set_test.cmj test/bs_node_string_buffer_test.cmi test/bs_node_string_buffer_test.cmj test/bs_poly_map_test.cmi test/bs_poly_map_test.cmj test/bs_poly_mutable_map_test.cmi test/bs_poly_mutable_map_test.cmj test/bs_poly_mutable_set_test.cmi test/bs_poly_mutable_set_test.cmj test/bs_poly_set_test.cmi test/bs_poly_set_test.cmj test/bs_qualified.cmi test/bs_qualified.cmj test/bs_queue_test.cmi test/bs_queue_test.cmj test/bs_rbset_int_bench.cmi test/bs_rbset_int_bench.cmj test/bs_rest_test.cmi test/bs_rest_test.cmj test/bs_set_bench.cmi test/bs_set_bench.cmj test/bs_set_int_test.cmi test/bs_set_int_test.cmj test/bs_sort_test.cmi test/bs_sort_test.cmj test/bs_splice_partial.cmi test/bs_splice_partial.cmj test/bs_stack_test.cmi test/bs_stack_test.cmj test/bs_string_test.cmi test/bs_string_test.cmj test/bs_unwrap_test.cmi test/bs_unwrap_test.cmj test/buffer_test.cmi test/buffer_test.cmj test/bytes_split_gpr_743_test.cmi test/bytes_split_gpr_743_test.cmj test/caml_compare_test.cmi test/caml_compare_test.cmj test/caml_format_test.cmi test/caml_format_test.cmj test/caml_sys_poly_fill_test.cmi test/caml_sys_poly_fill_test.cmj test/chain_code_test.cmi test/chain_code_test.cmj test/chn_test.cmi test/chn_test.cmj test/class_type_ffi_test.cmi test/class_type_ffi_test.cmj test/coercion_module_alias_test.cmi test/coercion_module_alias_test.cmj test/compare_test.cmi test/compare_test.cmj test/complete_parmatch_test.cmi test/complete_parmatch_test.cmj test/complex_if_test.cmi test/complex_if_test.cmj test/complex_test.cmi test/complex_test.cmj test/complex_while_loop.cmi test/complex_while_loop.cmj test/condition_compilation_test.cmi test/condition_compilation_test.cmj test/config1_test.cmi test/config1_test.cmj test/console_log_test.cmi test/console_log_test.cmj test/const_block_test.cmi test/const_block_test.cmj test/const_defs.cmi test/const_defs.cmj test/const_defs_test.cmi test/const_defs_test.cmj test/const_test.cmi test/const_test.cmj test/cont_int_fold_test.cmi test/cont_int_fold_test.cmj test/cps_test.cmi test/cps_test.cmj test/cross_module_inline_test.cmi test/cross_module_inline_test.cmj test/custom_error_test.cmi test/custom_error_test.cmj test/debug_keep_test.cmi test/debug_keep_test.cmj test/debug_mode_value.cmi test/debug_mode_value.cmj test/debug_tmp.cmi test/debug_tmp.cmj test/debugger_test.cmi test/debugger_test.cmj test/default_export_test.cmi test/default_export_test.cmj test/defunctor_make_test.cmi test/defunctor_make_test.cmj test/demo_int_map.cmi test/demo_int_map.cmj test/demo_page.cmi test/demo_page.cmj test/demo_pipe.cmi test/demo_pipe.cmj test/derive_dyntype.cmi test/derive_dyntype.cmj test/derive_projector_test.cmi test/derive_projector_test.cmj test/derive_type_test.cmi test/derive_type_test.cmj test/digest_test.cmi test/digest_test.cmj test/directives.cmi test/directives.cmj test/div_by_zero_test.cmi test/div_by_zero_test.cmj test/dollar_escape_test.cmi test/dollar_escape_test.cmj test/earger_curry_test.cmi test/earger_curry_test.cmj test/effect.cmi test/effect.cmj test/epsilon_test.cmi test/epsilon_test.cmj test/equal_box_test.cmi test/equal_box_test.cmj test/equal_exception_test.cmi test/equal_exception_test.cmj test/equal_test.cmi test/equal_test.cmj test/es6_export.cmi test/es6_export.cmj test/es6_import.cmi test/es6_import.cmj test/es6_module_test.cmi test/es6_module_test.cmj test/escape_esmodule.cmi test/escape_esmodule.cmj test/esmodule_ref.cmi test/esmodule_ref.cmj test/event_ffi.cmi test/event_ffi.cmj test/exception_alias.cmi test/exception_alias.cmj test/exception_def.cmi test/exception_def.cmj test/exception_raise_test.cmi test/exception_raise_test.cmj test/exception_rebind_test.cmi test/exception_rebind_test.cmj test/exception_rebound_err_test.cmi test/exception_rebound_err_test.cmj test/exception_value_test.cmi test/exception_value_test.cmj test/exn_error_pattern.cmi test/exn_error_pattern.cmj test/exponentiation_precedence_test.cmi test/exponentiation_precedence_test.cmj test/export_keyword.cmi test/export_keyword.cmj test/ext_array_test.cmi test/ext_array_test.cmj test/ext_bytes_test.cmi test/ext_bytes_test.cmj test/ext_filename_test.cmi test/ext_filename_test.cmj test/ext_list_test.cmi test/ext_list_test.cmj test/ext_pervasives_test.cmi test/ext_pervasives_test.cmj test/ext_string_test.cmi test/ext_string_test.cmj test/ext_sys_test.cmi test/ext_sys_test.cmj test/extensible_variant_test.cmi test/extensible_variant_test.cmj test/external_polyfill_test.cmi test/external_polyfill_test.cmj test/external_ppx.cmi test/external_ppx.cmj test/external_ppx2.cmi test/external_ppx2.cmj test/fail_comp.cmi test/fail_comp.cmj test/ffi_arity_test.cmi test/ffi_arity_test.cmj test/ffi_array_test.cmi test/ffi_array_test.cmj test/ffi_js_test.cmi test/ffi_js_test.cmj test/ffi_splice_test.cmi test/ffi_splice_test.cmj test/ffi_test.cmi test/ffi_test.cmj test/fib.cmi test/fib.cmj test/flattern_order_test.cmi test/flattern_order_test.cmj test/flexible_array_test.cmi test/flexible_array_test.cmj test/float_array.cmi test/float_array.cmj test/float_of_bits_test.cmi test/float_of_bits_test.cmj test/float_record.cmi test/float_record.cmj test/float_test.cmi test/float_test.cmj test/floatarray_test.cmi test/floatarray_test.cmj test/flow_parser_reg_test.cmi test/flow_parser_reg_test.cmj test/for_loop_test.cmi test/for_loop_test.cmj test/for_side_effect_test.cmi test/for_side_effect_test.cmj test/format_regression.cmi test/format_regression.cmj test/format_test.cmi test/format_test.cmj test/fs_test.cmi test/fs_test.cmj test/fun_pattern_match.cmi test/fun_pattern_match.cmj test/functor_app_test.cmi test/functor_app_test.cmj test/functor_def.cmi test/functor_def.cmj test/functor_ffi.cmi test/functor_ffi.cmj test/functor_inst.cmi test/functor_inst.cmj test/functors.cmi test/functors.cmj test/gbk.cmi test/gbk.cmj test/genlex_test.cmi test/genlex_test.cmj test/gentTypeReTest.cmi test/gentTypeReTest.cmj test/global_exception_regression_test.cmi test/global_exception_regression_test.cmj test/global_mangles.cmi test/global_mangles.cmj test/global_module_alias_test.cmi test/global_module_alias_test.cmj test/google_closure_test.cmi test/google_closure_test.cmj test/gpr496_test.cmi test/gpr496_test.cmj test/gpr_1072.cmi test/gpr_1072.cmj test/gpr_1072_reg.cmi test/gpr_1072_reg.cmj test/gpr_1150.cmi test/gpr_1150.cmj test/gpr_1154_test.cmi test/gpr_1154_test.cmj test/gpr_1170.cmi test/gpr_1170.cmj test/gpr_1240_missing_unbox.cmi test/gpr_1240_missing_unbox.cmj test/gpr_1245_test.cmi test/gpr_1245_test.cmj test/gpr_1268.cmi test/gpr_1268.cmj test/gpr_1409_test.cmi test/gpr_1409_test.cmj test/gpr_1423_app_test.cmi test/gpr_1423_app_test.cmj test/gpr_1423_nav.cmi test/gpr_1423_nav.cmj test/gpr_1438.cmi test/gpr_1438.cmj test/gpr_1481.cmi test/gpr_1481.cmj test/gpr_1484.cmi test/gpr_1484.cmj test/gpr_1503_test.cmi test/gpr_1503_test.cmj test/gpr_1539_test.cmi test/gpr_1539_test.cmj test/gpr_1658_test.cmi test/gpr_1658_test.cmj test/gpr_1667_test.cmi test/gpr_1667_test.cmj test/gpr_1692_test.cmi test/gpr_1692_test.cmj test/gpr_1698_test.cmi test/gpr_1698_test.cmj test/gpr_1701_test.cmi test/gpr_1701_test.cmj test/gpr_1716_test.cmi test/gpr_1716_test.cmj test/gpr_1717_test.cmi test/gpr_1717_test.cmj test/gpr_1728_test.cmi test/gpr_1728_test.cmj test/gpr_1749_test.cmi test/gpr_1749_test.cmj test/gpr_1759_test.cmi test/gpr_1759_test.cmj test/gpr_1760_test.cmi test/gpr_1760_test.cmj test/gpr_1762_test.cmi test/gpr_1762_test.cmj test/gpr_1817_test.cmi test/gpr_1817_test.cmj test/gpr_1822_test.cmi test/gpr_1822_test.cmj test/gpr_1891_test.cmi test/gpr_1891_test.cmj test/gpr_1943_test.cmi test/gpr_1943_test.cmj test/gpr_1946_test.cmi test/gpr_1946_test.cmj test/gpr_2316_test.cmi test/gpr_2316_test.cmj test/gpr_2352_test.cmi test/gpr_2352_test.cmj test/gpr_2413_test.cmi test/gpr_2413_test.cmj test/gpr_2474.cmi test/gpr_2474.cmj test/gpr_2487.cmi test/gpr_2487.cmj test/gpr_2503_test.cmi test/gpr_2503_test.cmj test/gpr_2608_test.cmi test/gpr_2608_test.cmj test/gpr_2614_test.cmi test/gpr_2614_test.cmj test/gpr_2633_test.cmi test/gpr_2633_test.cmj test/gpr_2642_test.cmi test/gpr_2642_test.cmj test/gpr_2652_test.cmi test/gpr_2652_test.cmj test/gpr_2682_test.cmi test/gpr_2682_test.cmj test/gpr_2700_test.cmi test/gpr_2700_test.cmj test/gpr_2731_test.cmi test/gpr_2731_test.cmj test/gpr_2789_test.cmi test/gpr_2789_test.cmj test/gpr_2931_test.cmi test/gpr_2931_test.cmj test/gpr_3142_test.cmi test/gpr_3142_test.cmj test/gpr_3154_test.cmi test/gpr_3154_test.cmj test/gpr_3209_test.cmi test/gpr_3209_test.cmj test/gpr_3492_test.cmi test/gpr_3492_test.cmj test/gpr_3519_jsx_test.cmi test/gpr_3519_jsx_test.cmj test/gpr_3519_test.cmi test/gpr_3519_test.cmj test/gpr_3536_test.cmi test/gpr_3536_test.cmj test/gpr_3546_test.cmi test/gpr_3546_test.cmj test/gpr_3548_test.cmi test/gpr_3548_test.cmj test/gpr_3549_test.cmi test/gpr_3549_test.cmj test/gpr_3566_drive_test.cmi test/gpr_3566_drive_test.cmj test/gpr_3566_test.cmi test/gpr_3566_test.cmj test/gpr_3595_test.cmi test/gpr_3595_test.cmj test/gpr_3609_test.cmi test/gpr_3609_test.cmj test/gpr_3697_test.cmi test/gpr_3697_test.cmj test/gpr_373_test.cmi test/gpr_373_test.cmj test/gpr_3770_test.cmi test/gpr_3770_test.cmj test/gpr_3852_alias.cmi test/gpr_3852_alias.cmj test/gpr_3852_alias_reify.cmi test/gpr_3852_alias_reify.cmj test/gpr_3852_effect.cmi test/gpr_3852_effect.cmj test/gpr_3865.cmi test/gpr_3865.cmj test/gpr_3865_bar.cmi test/gpr_3865_bar.cmj test/gpr_3865_foo.cmi test/gpr_3865_foo.cmj test/gpr_3875_test.cmi test/gpr_3875_test.cmj test/gpr_3877_test.cmi test/gpr_3877_test.cmj test/gpr_3895_test.cmi test/gpr_3895_test.cmj test/gpr_3897_test.cmi test/gpr_3897_test.cmj test/gpr_3931_test.cmi test/gpr_3931_test.cmj test/gpr_3980_test.cmi test/gpr_3980_test.cmj test/gpr_4025_test.cmi test/gpr_4025_test.cmj test/gpr_405_test.cmi test/gpr_405_test.cmj test/gpr_4069_test.cmi test/gpr_4069_test.cmj test/gpr_4265_test.cmi test/gpr_4265_test.cmj test/gpr_4274_test.cmi test/gpr_4274_test.cmj test/gpr_4280_test.cmi test/gpr_4280_test.cmj test/gpr_4407_test.cmi test/gpr_4407_test.cmj test/gpr_441.cmi test/gpr_441.cmj test/gpr_4442_test.cmi test/gpr_4442_test.cmj test/gpr_4491_test.cmi test/gpr_4491_test.cmj test/gpr_4494_test.cmi test/gpr_4494_test.cmj test/gpr_4519_test.cmi test/gpr_4519_test.cmj test/gpr_459_test.cmi test/gpr_459_test.cmj test/gpr_4632.cmi test/gpr_4632.cmj test/gpr_4639_test.cmi test/gpr_4639_test.cmj test/gpr_4900_test.cmi test/gpr_4900_test.cmj test/gpr_4924_test.cmi test/gpr_4924_test.cmj test/gpr_4931.cmi test/gpr_4931.cmj test/gpr_4931_allow.cmi test/gpr_4931_allow.cmj test/gpr_5071_test.cmi test/gpr_5071_test.cmj test/gpr_5169_test.cmi test/gpr_5169_test.cmj test/gpr_5218_test.cmi test/gpr_5218_test.cmj test/gpr_5280_optimize_test.cmi test/gpr_5280_optimize_test.cmj test/gpr_5312.cmi test/gpr_5312.cmj test/gpr_5557.cmi test/gpr_5557.cmj test/gpr_5753.cmi test/gpr_5753.cmj test/gpr_658.cmi test/gpr_658.cmj test/gpr_858_test.cmi test/gpr_858_test.cmj test/gpr_858_unit2_test.cmi test/gpr_858_unit2_test.cmj test/gpr_904_test.cmi test/gpr_904_test.cmj test/gpr_974_test.cmi test/gpr_974_test.cmj test/gpr_977_test.cmi test/gpr_977_test.cmj test/gpr_return_type_unused_attribute.cmi test/gpr_return_type_unused_attribute.cmj test/gray_code_test.cmi test/gray_code_test.cmj test/guide_for_ext.cmi test/guide_for_ext.cmj test/hamming_test.cmi test/hamming_test.cmj test/hash_collision_test.cmi test/hash_collision_test.cmj test/hash_sugar_desugar.cmi test/hash_sugar_desugar.cmj test/hash_test.cmi test/hash_test.cmj test/hashtbl_test.cmi test/hashtbl_test.cmj test/hello.foo.cmi test/hello.foo.cmj test/hello_res.cmi test/hello_res.cmj test/ignore_test.cmi test/ignore_test.cmj test/imm_map_bench.cmi test/imm_map_bench.cmj test/include_side_effect.cmi test/include_side_effect.cmj test/include_side_effect_free.cmi test/include_side_effect_free.cmj test/incomplete_toplevel_test.cmi test/incomplete_toplevel_test.cmj test/infer_type_test.cmi test/infer_type_test.cmj test/inline_const.cmi test/inline_const.cmj test/inline_const_test.cmi test/inline_const_test.cmj test/inline_edge_cases.cmi test/inline_edge_cases.cmj test/inline_map2_test.cmi test/inline_map2_test.cmj test/inline_map_demo.cmi test/inline_map_demo.cmj test/inline_map_test.cmi test/inline_map_test.cmj test/inline_record_test.cmi test/inline_record_test.cmj test/inline_regression_test.cmi test/inline_regression_test.cmj test/inline_string_test.cmi test/inline_string_test.cmj test/inner_call.cmi test/inner_call.cmj test/inner_define.cmi test/inner_define.cmj test/inner_unused.cmi test/inner_unused.cmj test/installation_test.cmi test/installation_test.cmj test/int32_test.cmi test/int32_test.cmj test/int64_mul_div_test.cmi test/int64_mul_div_test.cmj test/int64_string_bench.cmi test/int64_string_bench.cmj test/int64_string_test.cmi test/int64_string_test.cmj test/int64_test.cmi test/int64_test.cmj test/int_hashtbl_test.cmi test/int_hashtbl_test.cmj test/int_map.cmi test/int_map.cmj test/int_overflow_test.cmi test/int_overflow_test.cmj test/int_poly_var.cmi test/int_poly_var.cmj test/int_switch_test.cmi test/int_switch_test.cmj test/internal_unused_test.cmi test/internal_unused_test.cmj test/io_test.cmi test/io_test.cmj test/js_array_test.cmi test/js_array_test.cmj test/js_bool_test.cmi test/js_bool_test.cmj test/js_cast_test.cmi test/js_cast_test.cmj test/js_date_test.cmi test/js_date_test.cmj test/js_dict_test.cmi test/js_dict_test.cmj test/js_exception_catch_test.cmi test/js_exception_catch_test.cmj test/js_float_test.cmi test/js_float_test.cmj test/js_global_test.cmi test/js_global_test.cmj test/js_int_test.cmi test/js_int_test.cmj test/js_json_test.cmi test/js_json_test.cmj test/js_list_test.cmi test/js_list_test.cmj test/js_math_test.cmi test/js_math_test.cmj test/js_null_test.cmi test/js_null_test.cmj test/js_null_undefined_test.cmi test/js_null_undefined_test.cmj test/js_nullable_test.cmi test/js_nullable_test.cmj test/js_obj_test.cmi test/js_obj_test.cmj test/js_option_test.cmi test/js_option_test.cmj test/js_promise_basic_test.cmi test/js_promise_basic_test.cmj test/js_re_test.cmi test/js_re_test.cmj test/js_string_test.cmi test/js_string_test.cmj test/js_typed_array_test.cmi test/js_typed_array_test.cmj test/js_undefined_test.cmi test/js_undefined_test.cmj test/js_val.cmi test/js_val.cmj test/jsoo_400_test.cmi test/jsoo_400_test.cmj test/jsoo_485_test.cmi test/jsoo_485_test.cmj test/jsxv4_newtype.cmi test/jsxv4_newtype.cmj test/key_word_property.cmi test/key_word_property.cmj test/key_word_property2.cmi test/key_word_property2.cmj test/key_word_property_plus_test.cmi test/key_word_property_plus_test.cmj test/label_uncurry.cmi test/label_uncurry.cmj test/large_integer_pat.cmi test/large_integer_pat.cmj test/large_record_duplication_test.cmi test/large_record_duplication_test.cmj test/largest_int_flow.cmi test/largest_int_flow.cmj test/lazy_demo.cmi test/lazy_demo.cmj test/lazy_test.cmi test/lazy_test.cmj test/lexer_test.cmi test/lexer_test.cmj test/lib_js_test.cmi test/lib_js_test.cmj test/libarg_test.cmi test/libarg_test.cmj test/libqueue_test.cmi test/libqueue_test.cmj test/limits_test.cmi test/limits_test.cmj test/list_stack.cmi test/list_stack.cmj test/list_test.cmi test/list_test.cmj test/local_exception_test.cmi test/local_exception_test.cmj test/loop_regression_test.cmi test/loop_regression_test.cmj test/loop_suites_test.cmi test/loop_suites_test.cmj test/map_find_test.cmi test/map_find_test.cmj test/map_test.cmi test/map_test.cmj test/mario_game.cmi test/mario_game.cmj test/marshal.cmi test/marshal.cmj test/meth_annotation.cmi test/meth_annotation.cmj test/method_name_test.cmi test/method_name_test.cmj test/method_string_name.cmi test/method_string_name.cmj test/minimal_test.cmi test/minimal_test.cmj test/miss_colon_test.cmi test/miss_colon_test.cmj test/mock_mt.cmi test/mock_mt.cmj test/module_alias_test.cmi test/module_alias_test.cmj test/module_as_class_ffi.cmi test/module_as_class_ffi.cmj test/module_as_function.cmi test/module_as_function.cmj test/module_missing_conversion.cmi test/module_missing_conversion.cmj test/module_parameter_test.cmi test/module_parameter_test.cmj test/module_splice_test.cmi test/module_splice_test.cmj test/more_poly_variant_test.cmi test/more_poly_variant_test.cmj test/more_uncurry.cmi test/more_uncurry.cmj test/mpr_6033_test.cmi test/mpr_6033_test.cmj test/mt.cmi test/mt.cmj test/mt_global.cmi test/mt_global.cmj test/mutable_obj_test.cmi test/mutable_obj_test.cmj test/mutable_uncurry_test.cmi test/mutable_uncurry_test.cmj test/mutual_non_recursive_type.cmi test/mutual_non_recursive_type.cmj test/name_mangle_test.cmi test/name_mangle_test.cmj test/nested_include.cmi test/nested_include.cmj test/nested_module_alias.cmi test/nested_module_alias.cmj test/nested_obj_literal.cmi test/nested_obj_literal.cmj test/nested_obj_test.cmi test/nested_obj_test.cmj test/nested_pattern_match_test.cmi test/nested_pattern_match_test.cmj test/noassert.cmi test/noassert.cmj test/node_fs_test.cmi test/node_fs_test.cmj test/node_path_test.cmi test/node_path_test.cmj test/null_list_test.cmi test/null_list_test.cmj test/number_lexer.cmi test/number_lexer.cmj test/obj_literal_ppx.cmi test/obj_literal_ppx.cmj test/obj_literal_ppx_test.cmi test/obj_literal_ppx_test.cmj test/obj_magic_test.cmi test/obj_magic_test.cmj test/obj_type_test.cmi test/obj_type_test.cmj test/ocaml_re_test.cmi test/ocaml_re_test.cmj test/of_string_test.cmi test/of_string_test.cmj test/offset.cmi test/offset.cmj test/option_encoding_test.cmi test/option_encoding_test.cmj test/option_record_none_test.cmi test/option_record_none_test.cmj test/option_repr_test.cmi test/option_repr_test.cmj test/optional_ffi_test.cmi test/optional_ffi_test.cmj test/optional_regression_test.cmi test/optional_regression_test.cmj test/pipe_send_readline.cmi test/pipe_send_readline.cmj test/pipe_syntax.cmi test/pipe_syntax.cmj test/poly_empty_array.cmi test/poly_empty_array.cmj test/poly_variant_test.cmi test/poly_variant_test.cmj test/polymorphic_raw_test.cmi test/polymorphic_raw_test.cmj test/polymorphism_test.cmi test/polymorphism_test.cmj test/polyvar_convert.cmi test/polyvar_convert.cmj test/polyvar_test.cmi test/polyvar_test.cmj test/ppx_apply_test.cmi test/ppx_apply_test.cmj test/pq_test.cmi test/pq_test.cmj test/pr6726.cmi test/pr6726.cmj test/pr_regression_test.cmi test/pr_regression_test.cmj test/prepend_data_ffi.cmi test/prepend_data_ffi.cmj test/primitive_reg_test.cmi test/primitive_reg_test.cmj test/print_alpha_test.cmi test/print_alpha_test.cmj test/promise_catch_test.cmi test/promise_catch_test.cmj test/queue_402.cmi test/queue_402.cmj test/queue_test.cmi test/queue_test.cmj test/random_test.cmi test/random_test.cmj test/raw_hash_tbl_bench.cmi test/raw_hash_tbl_bench.cmj test/raw_output_test.cmi test/raw_output_test.cmj test/raw_pure_test.cmi test/raw_pure_test.cmj test/rbset.cmi test/rbset.cmj test/react.cmi test/react.cmj test/reactDOMRe.cmi test/reactDOMRe.cmj test/reactDOMServerRe.cmi test/reactDOMServerRe.cmj test/reactEvent.cmi test/reactEvent.cmj test/reactTestUtils.cmi test/reactTestUtils.cmj test/reasonReact.cmi test/reasonReact.cmj test/reasonReactCompat.cmi test/reasonReactCompat.cmj test/reasonReactOptimizedCreateClass.cmi test/reasonReactOptimizedCreateClass.cmj test/reasonReactRouter.cmi test/reasonReactRouter.cmj test/rebind_module.cmi test/rebind_module.cmj test/rebind_module_test.cmi test/rebind_module_test.cmj test/rec_array_test.cmi test/rec_array_test.cmj test/rec_fun_test.cmi test/rec_fun_test.cmj test/rec_module_opt.cmi test/rec_module_opt.cmj test/rec_module_test.cmi test/rec_module_test.cmj test/rec_value_test.cmi test/rec_value_test.cmj test/record_debug_test.cmi test/record_debug_test.cmj test/record_extension_test.cmi test/record_extension_test.cmj test/record_name_test.cmi test/record_name_test.cmj test/record_regression.cmi test/record_regression.cmj test/record_with_test.cmi test/record_with_test.cmj test/recursive_module.cmi test/recursive_module.cmj test/recursive_module_test.cmi test/recursive_module_test.cmj test/recursive_react_component.cmi test/recursive_react_component.cmj test/recursive_records_test.cmi test/recursive_records_test.cmj test/recursive_unbound_module_test.cmi test/recursive_unbound_module_test.cmj test/regression_print.cmi test/regression_print.cmj test/relative_path.cmi test/relative_path.cmj test/res_debug.cmi test/res_debug.cmj test/return_check.cmi test/return_check.cmj test/runtime_encoding_test.cmi test/runtime_encoding_test.cmj test/set_annotation.cmi test/set_annotation.cmj test/set_gen.cmi test/set_gen.cmj test/sexp.cmi test/sexp.cmj test/sexpm.cmi test/sexpm.cmj test/sexpm_test.cmi test/sexpm_test.cmj test/side_effect.cmi test/side_effect.cmj test/side_effect_free.cmi test/side_effect_free.cmj test/simple_derive_test.cmi test/simple_derive_test.cmj test/simple_derive_use.cmi test/simple_derive_use.cmj test/simple_lexer_test.cmi test/simple_lexer_test.cmj test/simplify_lambda_632o.cmi test/simplify_lambda_632o.cmj test/single_module_alias.cmi test/single_module_alias.cmj test/singular_unit_test.cmi test/singular_unit_test.cmj test/small_inline_test.cmi test/small_inline_test.cmj test/splice_test.cmi test/splice_test.cmj test/stack_comp_test.cmi test/stack_comp_test.cmj test/stack_test.cmi test/stack_test.cmj test/stream_parser_test.cmi test/stream_parser_test.cmj test/string_bound_get_test.cmi test/string_bound_get_test.cmj test/string_constant_compare.cmi test/string_constant_compare.cmj test/string_get_set_test.cmi test/string_get_set_test.cmj test/string_literal_print_test.cmi test/string_literal_print_test.cmj test/string_runtime_test.cmi test/string_runtime_test.cmj test/string_set.cmi test/string_set.cmj test/string_set_test.cmi test/string_set_test.cmj test/string_test.cmi test/string_test.cmj test/string_unicode_test.cmi test/string_unicode_test.cmj test/stringmatch_test.cmi test/stringmatch_test.cmj test/submodule.cmi test/submodule.cmj test/submodule_call.cmi test/submodule_call.cmj test/switch_case_test.cmi test/switch_case_test.cmj test/switch_string.cmi test/switch_string.cmj test/tailcall_inline_test.cmi test/tailcall_inline_test.cmj test/template.cmi test/template.cmj test/test.cmi test/test.cmj test/test2.cmi test/test2.cmj test/test_alias.cmi test/test_alias.cmj test/test_ari.cmi test/test_ari.cmj test/test_array.cmi test/test_array.cmj test/test_array_append.cmi test/test_array_append.cmj test/test_array_primitive.cmi test/test_array_primitive.cmj test/test_bool_equal.cmi test/test_bool_equal.cmj test/test_bs_this.cmi test/test_bs_this.cmj test/test_bug.cmi test/test_bug.cmj test/test_bytes.cmi test/test_bytes.cmj test/test_case_opt_collision.cmi test/test_case_opt_collision.cmj test/test_case_set.cmi test/test_case_set.cmj test/test_char.cmi test/test_char.cmj test/test_closure.cmi test/test_closure.cmj test/test_common.cmi test/test_common.cmj test/test_const_elim.cmi test/test_const_elim.cmj test/test_const_propogate.cmi test/test_const_propogate.cmj test/test_cpp.cmi test/test_cpp.cmj test/test_cps.cmi test/test_cps.cmj test/test_demo.cmi test/test_demo.cmj test/test_dup_param.cmi test/test_dup_param.cmj test/test_eq.cmi test/test_eq.cmj test/test_exception.cmi test/test_exception.cmj test/test_exception_escape.cmi test/test_exception_escape.cmj test/test_export2.cmi test/test_export2.cmj test/test_external.cmi test/test_external.cmj test/test_external_unit.cmi test/test_external_unit.cmj test/test_ffi.cmi test/test_ffi.cmj test/test_fib.cmi test/test_fib.cmj test/test_filename.cmi test/test_filename.cmj test/test_for_loop.cmi test/test_for_loop.cmj test/test_for_map.cmi test/test_for_map.cmj test/test_for_map2.cmi test/test_for_map2.cmj test/test_format.cmi test/test_format.cmj test/test_formatter.cmi test/test_formatter.cmj test/test_functor_dead_code.cmi test/test_functor_dead_code.cmj test/test_generative_module.cmi test/test_generative_module.cmj test/test_global_print.cmi test/test_global_print.cmj test/test_google_closure.cmi test/test_google_closure.cmj test/test_include.cmi test/test_include.cmj test/test_incomplete.cmi test/test_incomplete.cmj test/test_incr_ref.cmi test/test_incr_ref.cmj test/test_int_map_find.cmi test/test_int_map_find.cmj test/test_internalOO.cmi test/test_internalOO.cmj test/test_is_js.cmi test/test_is_js.cmj test/test_js_ffi.cmi test/test_js_ffi.cmj test/test_let.cmi test/test_let.cmj test/test_list.cmi test/test_list.cmj test/test_literal.cmi test/test_literal.cmj test/test_literals.cmi test/test_literals.cmj test/test_match_exception.cmi test/test_match_exception.cmj test/test_mutliple.cmi test/test_mutliple.cmj test/test_nat64.cmi test/test_nat64.cmj test/test_nested_let.cmi test/test_nested_let.cmj test/test_nested_print.cmi test/test_nested_print.cmj test/test_non_export.cmi test/test_non_export.cmj test/test_nullary.cmi test/test_nullary.cmj test/test_obj.cmi test/test_obj.cmj test/test_obj_simple_ffi.cmi test/test_obj_simple_ffi.cmj test/test_order.cmi test/test_order.cmj test/test_order_tailcall.cmi test/test_order_tailcall.cmj test/test_other_exn.cmi test/test_other_exn.cmj test/test_pack.cmi test/test_pack.cmj test/test_per.cmi test/test_per.cmj test/test_pervasive.cmi test/test_pervasive.cmj test/test_pervasives2.cmi test/test_pervasives2.cmj test/test_pervasives3.cmi test/test_pervasives3.cmj test/test_primitive.cmi test/test_primitive.cmj test/test_ramification.cmi test/test_ramification.cmj test/test_react.cmi test/test_react.cmj test/test_react_case.cmi test/test_react_case.cmj test/test_regex.cmi test/test_regex.cmj test/test_require.cmi test/test_require.cmj test/test_runtime_encoding.cmi test/test_runtime_encoding.cmj test/test_scope.cmi test/test_scope.cmj test/test_seq.cmi test/test_seq.cmj test/test_set.cmi test/test_set.cmj test/test_side_effect_functor.cmi test/test_side_effect_functor.cmj test/test_simple_include.cmi test/test_simple_include.cmj test/test_simple_pattern_match.cmi test/test_simple_pattern_match.cmj test/test_simple_ref.cmi test/test_simple_ref.cmj test/test_simple_tailcall.cmi test/test_simple_tailcall.cmj test/test_small.cmi test/test_small.cmj test/test_sprintf.cmi test/test_sprintf.cmj test/test_stack.cmi test/test_stack.cmj test/test_static_catch_ident.cmi test/test_static_catch_ident.cmj test/test_string.cmi test/test_string.cmj test/test_string_case.cmi test/test_string_case.cmj test/test_string_const.cmi test/test_string_const.cmj test/test_string_map.cmi test/test_string_map.cmj test/test_string_switch.cmi test/test_string_switch.cmj test/test_switch.cmi test/test_switch.cmj test/test_trywith.cmi test/test_trywith.cmj test/test_tuple.cmi test/test_tuple.cmj test/test_tuple_destructring.cmi test/test_tuple_destructring.cmj test/test_type_based_arity.cmi test/test_type_based_arity.cmj test/test_u.cmi test/test_u.cmj test/test_unknown.cmi test/test_unknown.cmj test/test_unsafe_cmp.cmi test/test_unsafe_cmp.cmj test/test_unsafe_obj_ffi.cmi test/test_unsafe_obj_ffi.cmj test/test_unsafe_obj_ffi_ppx.cmi test/test_unsafe_obj_ffi_ppx.cmj test/test_unsupported_primitive.cmi test/test_unsupported_primitive.cmj test/test_while_closure.cmi test/test_while_closure.cmj test/test_while_side_effect.cmi test/test_while_side_effect.cmj test/test_zero_nullable.cmi test/test_zero_nullable.cmj test/then_mangle_test.cmi test/then_mangle_test.cmj test/ticker.cmi test/ticker.cmj test/to_string_test.cmi test/to_string_test.cmj test/topsort_test.cmi test/topsort_test.cmj test/tramp_fib.cmi test/tramp_fib.cmj test/tuple_alloc.cmi test/tuple_alloc.cmj test/type_disambiguate.cmi test/type_disambiguate.cmj test/typeof_test.cmi test/typeof_test.cmj test/ui_defs.cmi test/unboxed_attribute.cmi test/unboxed_attribute.cmj test/unboxed_attribute_test.cmi test/unboxed_attribute_test.cmj test/unboxed_crash.cmi test/unboxed_crash.cmj test/unboxed_use_case.cmi test/unboxed_use_case.cmj test/uncurried_cast.cmi test/uncurried_cast.cmj test/uncurried_default.args.cmi test/uncurried_default.args.cmj test/uncurried_pipe.cmi test/uncurried_pipe.cmj test/uncurry_external_test.cmi test/uncurry_external_test.cmj test/uncurry_glob_test.cmi test/uncurry_glob_test.cmj test/uncurry_test.cmi test/uncurry_test.cmj test/undef_regression2_test.cmi test/undef_regression2_test.cmj test/undef_regression_test.cmi test/undef_regression_test.cmj test/undefine_conditional.cmi test/undefine_conditional.cmj test/unicode_type_error.cmi test/unicode_type_error.cmj test/unit_undefined_test.cmi test/unit_undefined_test.cmj test/unitest_string.cmi test/unitest_string.cmj test/unsafe_full_apply_primitive.cmi test/unsafe_full_apply_primitive.cmj test/unsafe_ppx_test.cmi test/unsafe_ppx_test.cmj test/unsafe_this.cmi test/unsafe_this.cmj test/update_record_test.cmi test/update_record_test.cmj test/utf8_decode_test.cmi test/utf8_decode_test.cmj test/variant.cmi test/variant.cmj test/watch_test.cmi test/watch_test.cmj test/webpack_config.cmi test/webpack_config.cmj diff --git a/jscomp/test/caml_format_test.js b/jscomp/test/caml_format_test.js index 404681f640..798c0bf35b 100644 --- a/jscomp/test/caml_format_test.js +++ b/jscomp/test/caml_format_test.js @@ -88,7 +88,7 @@ function from_of_string(xs) { var b = param[1]; var a = param[0]; return [ - "of_string " + i, + "of_string " + String(i) + "", (function (param) { return { TAG: /* Eq */0, @@ -156,7 +156,7 @@ var suites = Pervasives.$at(from_of_string(of_string), Pervasives.$at({ var b = param[1]; var a = param[0]; return [ - "infinity_of_string " + i, + "infinity_of_string " + String(i) + "", (function (param) { return { TAG: /* Eq */0, @@ -194,7 +194,7 @@ var suites = Pervasives.$at(from_of_string(of_string), Pervasives.$at({ var b = param[1]; var a = param[0]; return [ - "normal_float_of_string " + i, + "normal_float_of_string " + String(i) + "", (function (param) { return { TAG: /* Eq */0, @@ -427,7 +427,7 @@ Mt.from_pair_suites("Caml_format_test", Pervasives.$at(suites, Pervasives.$at($$ var f = param[1]; var fmt = param[0]; return [ - "loat_format " + i, + "loat_format " + String(i) + "", (function (param) { return { TAG: /* Eq */0, @@ -440,7 +440,7 @@ Mt.from_pair_suites("Caml_format_test", Pervasives.$at(suites, Pervasives.$at($$ var b = param[1]; var a = param[0]; return [ - "int64_of_string " + i + " ", + "int64_of_string " + String(i) + " ", (function (param) { return { TAG: /* Eq */0, diff --git a/jscomp/test/caml_format_test.ml b/jscomp/test/caml_format_test.ml deleted file mode 100644 index 5fcd0164e2..0000000000 --- a/jscomp/test/caml_format_test.ml +++ /dev/null @@ -1,148 +0,0 @@ -[@@@warning "-107"] - -let of_string = - [| (0, "0"); (3, "03"); (-3, "-03"); (-63, "-0x3f"); (-31, "-0x1f"); - (47, "0X2f"); (11, "0O13"); (8, "0o10"); (3, "0b11"); (1, "0b01"); - (0, "0b00"); (-3, "-0b11"); (-5, "-0B101"); (332, "0332"); (-32, "-32"); - (-4294967295, "-0xffff_ffff"); - (-1, "0xffff_ffff") - |] - -(* let float_of_string = *) -(* [| "nan", nan ; *) -(* "infinity", infinity; *) -(* "0.", 0. *) -(* |] *) - -let from_float_of_string xs = - xs - |> Array.mapi (fun i (a,b) -> - string_of_float - ) - -let from_of_string xs = - of_string - |> Array.mapi (fun i (a,b) -> - ({j|of_string $i|j} ), fun _ -> Mt.Eq(int_of_string b,a )) - |> Array.to_list - - -let to_str s = int_of_string s - - -external format_int : string -> int -> string = "?format_int" - -let suites : Mt.pair_suites = - from_of_string of_string @ - ["isnan_of_string", (fun _ -> - Mt.Eq (true,classify_float( float_of_string "nan") = FP_nan))] @ - (let pairs = - [| FP_infinite, "infinity"; - FP_infinite, "+infinity"; - FP_infinite, "-infinity"; - FP_zero, "0"; - FP_zero, "0." - |] - in - pairs - |> Array.mapi - (fun i (a,b) -> - ({j|infinity_of_string $i|j} ), - (fun _ -> Mt.Eq(a, - classify_float @@ float_of_string b))) - |> Array.to_list ) @ - [ "throw", (fun _ -> Mt.ThrowAny (fun _ -> ignore @@ float_of_string "")); - "format_int", (fun _ -> - Mt.Eq(" 33", format_int "%32d" 33)) - ] @ - (let pairs = - [| 3232., "32_32.0"; - 1.000, "1.000"; - 12.000, "12.000" - |] - in - pairs - |> Array.mapi - (fun i (a,b) -> - ({j|normal_float_of_string $i|j} ), - (fun _ -> Mt.Eq(a, - float_of_string b))) - |> Array.to_list ) - - - -let ff = format_int "%32d" - -external format_float: string -> float -> string - = "?format_float" - -(* ("%3.10f", 3e+56, *) - (* "300000000000000005792779041490073052596128503513888063488.0000000000"); *) - -let float_data = - [|("%f", 32., "32.000000"); ("%f", nan, "nan"); ("%f", infinity, "inf"); - ("%f", neg_infinity, "-inf"); ("%1.e", 13000., "1e+04"); - ("%1.3e", 2.3e-05, "2.300e-05"); ("%3.10e", 3e+56, "3.0000000000e+56"); - ("%3.10f", 20000000000., "20000000000.0000000000"); - ("%3.3f", -3300., "-3300.000"); ("%1.g", 13000., "1e+04"); - ("%1.3g", 2.3e-05, "2.3e-05"); ("%3.10g", 3e+56, "3e+56"); - ("%3.10g", 20000000000., "2e+10"); ("%3.3g", -3300., "-3.3e+03"); - ("%3.3g", -0.0033, "-0.0033"); ("%3.10g", 30000000000., "3e+10"); - ("%3.0g", 30000000000., "3e+10"); ("%3.g", 30000000000., "3e+10"); - ("%3.g", 3., " 3"); ("%1.1g", 2.1, "2"); ("%1.2g", 2.1, "2.1")|] - -let float_suites = Mt.[ - "float_nan" - ] - - - - -(* module Mt = Mock_mt *) - -let int64_suites = - - Mt.[ - - - "i64_simple7", (fun _ -> Eq(Int64.to_string 3333L, "3333")); - "i64_simple15", (fun _ -> - Eq( Int64.to_string (-1L), "-1")); - "i64_simple16", (fun _ -> - Eq( Int64.to_string (-11111L), "-11111")); - - ] - -let hh = 922337203685477580L (* 2 ^ 63 / 10 *) -let hhh = 1152921504606846976L -let of_string_data = - [| (0L, "0"); - (3L, "3"); - (33L, "33"); - (333L, "33_3"); - (33333L, "33_33_3"); - (333333333333L, "333333333333"); - (-1L, "0xffff_ffff_ffff_ffff"); - (113L, "0b01110001"); - (1L, "-0xffff_ffff_ffff_ffff") - |] - -(* module Mt = Mock_mt *) - -let () = - Mt.from_pair_suites __MODULE__ @@ - suites @ - - - (Array.mapi (fun i (fmt, f,str_result) -> ({j|loat_format $i|j} ) , (fun _ -> Mt.Eq(format_float fmt f, str_result))) float_data |> Array.to_list) @ - - int64_suites @ - (of_string_data - |> - Array.mapi (fun i (a,b) -> - (({j|int64_of_string $i |j}), fun _ -> Mt.Eq(Int64.of_string b, a) ) - ) - |> Array.to_list ) - - - diff --git a/jscomp/test/caml_format_test.res b/jscomp/test/caml_format_test.res new file mode 100644 index 0000000000..b69981df68 --- /dev/null +++ b/jscomp/test/caml_format_test.res @@ -0,0 +1,167 @@ +@@warning("-107") + +let of_string = [ + (0, "0"), + (3, "03"), + (-3, "-03"), + (-63, "-0x3f"), + (-31, "-0x1f"), + (47, "0X2f"), + (11, "0O13"), + (8, "0o10"), + (3, "0b11"), + (1, "0b01"), + (0, "0b00"), + (-3, "-0b11"), + (-5, "-0B101"), + (332, "0332"), + (-32, "-32"), + (-4294967295, "-0xffff_ffff"), + (-1, "0xffff_ffff"), +] + +/* let float_of_string = */ +/* [| "nan", nan ; */ +/* "infinity", infinity; */ +/* "0.", 0. */ +/* |] */ + +let from_float_of_string = xs => xs |> Array.mapi((i, (a, b)) => string_of_float) + +let from_of_string = xs => + of_string + |> Array.mapi((i, (a, b)) => (`of_string ${string_of_int(i)}`, _ => Mt.Eq(int_of_string(b), a))) + |> Array.to_list + +let to_str = s => int_of_string(s) + +external format_int: (string, int) => string = "?format_int" + +let suites: Mt.pair_suites = \"@"( + from_of_string(of_string), + \"@"( + list{("isnan_of_string", _ => Mt.Eq(true, classify_float(float_of_string("nan")) == FP_nan))}, + \"@"( + { + let pairs = [ + (FP_infinite, "infinity"), + (FP_infinite, "+infinity"), + (FP_infinite, "-infinity"), + (FP_zero, "0"), + (FP_zero, "0."), + ] + + pairs + |> Array.mapi((i, (a, b)) => ( + `infinity_of_string ${string_of_int(i)}`, + _ => Mt.Eq(a, \"@@"(classify_float, float_of_string(b))), + )) + |> Array.to_list + }, + \"@"( + list{ + ("throw", _ => Mt.ThrowAny(_ => \"@@"(ignore, float_of_string("")))), + ("format_int", _ => Mt.Eq(" 33", format_int("%32d", 33))), + }, + { + let pairs = [(3232., "32_32.0"), (1.000, "1.000"), (12.000, "12.000")] + + pairs + |> Array.mapi((i, (a, b)) => ( + `normal_float_of_string ${string_of_int(i)}`, + _ => Mt.Eq(a, float_of_string(b)), + )) + |> Array.to_list + }, + ), + ), + ), +) + +let ff = format_int("%32d") + +external format_float: (string, float) => string = "?format_float" + +/* ("%3.10f", 3e+56, */ +/* "300000000000000005792779041490073052596128503513888063488.0000000000"); */ + +let float_data = [ + ("%f", 32., "32.000000"), + ("%f", nan, "nan"), + ("%f", infinity, "inf"), + ("%f", neg_infinity, "-inf"), + ("%1.e", 13000., "1e+04"), + ("%1.3e", 2.3e-05, "2.300e-05"), + ("%3.10e", 3e+56, "3.0000000000e+56"), + ("%3.10f", 20000000000., "20000000000.0000000000"), + ("%3.3f", -3300., "-3300.000"), + ("%1.g", 13000., "1e+04"), + ("%1.3g", 2.3e-05, "2.3e-05"), + ("%3.10g", 3e+56, "3e+56"), + ("%3.10g", 20000000000., "2e+10"), + ("%3.3g", -3300., "-3.3e+03"), + ("%3.3g", -0.0033, "-0.0033"), + ("%3.10g", 30000000000., "3e+10"), + ("%3.0g", 30000000000., "3e+10"), + ("%3.g", 30000000000., "3e+10"), + ("%3.g", 3., " 3"), + ("%1.1g", 2.1, "2"), + ("%1.2g", 2.1, "2.1"), +] + +let float_suites = { + open Mt + list{"float_nan"} +} + +/* module Mt = Mock_mt */ + +let int64_suites = { + open Mt + list{ + ("i64_simple7", _ => Eq(Int64.to_string(3333L), "3333")), + ("i64_simple15", _ => Eq(Int64.to_string(-1L), "-1")), + ("i64_simple16", _ => Eq(Int64.to_string(-11111L), "-11111")), + } +} + +let hh = 922337203685477580L /* 2 ^ 63 / 10 */ +let hhh = 1152921504606846976L +let of_string_data = [ + (0L, "0"), + (3L, "3"), + (33L, "33"), + (333L, "33_3"), + (33333L, "33_33_3"), + (333333333333L, "333333333333"), + (-1L, "0xffff_ffff_ffff_ffff"), + (113L, "0b01110001"), + (1L, "-0xffff_ffff_ffff_ffff"), +] + +/* module Mt = Mock_mt */ + +let () = \"@@"( + Mt.from_pair_suites(__MODULE__), + \"@"( + suites, + \"@"( + Array.mapi( + (i, (fmt, f, str_result)) => ( + `loat_format ${string_of_int(i)}`, + _ => Mt.Eq(format_float(fmt, f), str_result), + ), + float_data, + ) |> Array.to_list, + \"@"( + int64_suites, + of_string_data + |> Array.mapi((i, (a, b)) => ( + `int64_of_string ${string_of_int(i)} `, + _ => Mt.Eq(Int64.of_string(b), a), + )) + |> Array.to_list, + ), + ), + ), +) diff --git a/jscomp/test/chn_test.js b/jscomp/test/chn_test.js index a0b269ba5d..b08d24631c 100644 --- a/jscomp/test/chn_test.js +++ b/jscomp/test/chn_test.js @@ -42,18 +42,18 @@ function convert(s) { throw { RE_EXN_ID: "Assert_failure", _1: [ - "chn_test.ml", - 20, - 18 + "chn_test.res", + 17, + 14 ], Error: new Error() }; }))); } -eq("File \"chn_test.ml\", line 25, characters 7-14", "你好，\n世界", "你好，\n世界"); +eq("File \"chn_test.res\", line 24, characters 4-11", "你好，\n世界", "你好，\n世界"); -eq("File \"chn_test.ml\", line 27, characters 7-14", convert("汉字是世界上最美丽的character"), { +eq("File \"chn_test.res\", line 30, characters 4-11", convert("汉字是世界上最美丽的character"), { hd: 27721, tl: { hd: 23383, @@ -112,7 +112,7 @@ eq("File \"chn_test.ml\", line 27, characters 7-14", convert("汉字是世界上 } }); -eq("File \"chn_test.ml\", line 48, characters 5-12", convert("\x3f\x3fa"), { +eq("File \"chn_test.res\", line 54, characters 5-12", convert("\x3f\x3fa"), { hd: 63, tl: { hd: 63, @@ -123,7 +123,7 @@ eq("File \"chn_test.ml\", line 48, characters 5-12", convert("\x3f\x3fa"), { } }); -eq("File \"chn_test.ml\", line 50, characters 5-12", convert("??a"), { +eq("File \"chn_test.res\", line 55, characters 5-12", convert("??a"), { hd: 63, tl: { hd: 63, @@ -134,7 +134,7 @@ eq("File \"chn_test.ml\", line 50, characters 5-12", convert("??a"), { } }); -eq("File \"chn_test.ml\", line 52, characters 5-12", convert("\u003f\x3fa"), { +eq("File \"chn_test.res\", line 56, characters 5-12", convert("\u003f\x3fa"), { hd: 63, tl: { hd: 63, @@ -145,7 +145,7 @@ eq("File \"chn_test.ml\", line 52, characters 5-12", convert("\u003f\x3fa"), { } }); -eq("File \"chn_test.ml\", line 54, characters 5-12", convert("🚀🚀a"), { +eq("File \"chn_test.res\", line 57, characters 5-12", convert("🚀🚀a"), { hd: 128640, tl: { hd: 128640, @@ -156,7 +156,7 @@ eq("File \"chn_test.ml\", line 54, characters 5-12", convert("🚀🚀a"), { } }); -eq("File \"chn_test.ml\", line 56, characters 5-12", convert("\uD83D\uDE80a"), { +eq("File \"chn_test.res\", line 58, characters 5-12", convert("\uD83D\uDE80a"), { hd: 128640, tl: { hd: 97, @@ -164,7 +164,7 @@ eq("File \"chn_test.ml\", line 56, characters 5-12", convert("\uD83D\uDE80a"), { } }); -eq("File \"chn_test.ml\", line 58, characters 5-12", convert("\uD83D\uDE80\x3f"), { +eq("File \"chn_test.res\", line 59, characters 5-12", convert("\uD83D\uDE80\x3f"), { hd: 128640, tl: { hd: 63, @@ -172,7 +172,7 @@ eq("File \"chn_test.ml\", line 58, characters 5-12", convert("\uD83D\uDE80\x3f") } }); -eq("File \"chn_test.ml\", line 63, characters 5-12", convert("\uD83D\uDE80\uD83D\uDE80a"), { +eq("File \"chn_test.res\", line 63, characters 5-12", convert("\uD83D\uDE80\uD83D\uDE80a"), { hd: 128640, tl: { hd: 128640, @@ -185,16 +185,16 @@ eq("File \"chn_test.ml\", line 63, characters 5-12", convert("\uD83D\uDE80\uD83D eq("No inline string length", "\uD83D\uDE80\0".length, 3); -eq("File \"chn_test.ml\", line 72, characters 6-13", Caml_string.get("\uD83D\uDE80\0", 0), 128640); +eq("File \"chn_test.res\", line 70, characters 4-11", Caml_string.get("\uD83D\uDE80\0", 0), 128640); -eq("File \"chn_test.ml\", line 76, characters 6-13", Caml_string.get("🚀", 0), 128640); +eq("File \"chn_test.res\", line 75, characters 5-12", Caml_string.get("🚀", 0), 128640); -eq("File \"chn_test.ml\", line 81, characters 5-12", convert("\uD83D\uDE80"), { +eq("File \"chn_test.res\", line 80, characters 5-12", convert("\uD83D\uDE80"), { hd: 128640, tl: /* [] */0 }); -eq("File \"chn_test.ml\", line 83, characters 5-12", convert("\uD83D\uDE80\uD83D\uDE80"), { +eq("File \"chn_test.res\", line 81, characters 5-12", convert("\uD83D\uDE80\uD83D\uDE80"), { hd: 128640, tl: { hd: 128640, @@ -202,7 +202,7 @@ eq("File \"chn_test.ml\", line 83, characters 5-12", convert("\uD83D\uDE80\uD83D } }); -eq("File \"chn_test.ml\", line 84, characters 5-12", convert(" \b\t\n\v\f\ra"), { +eq("File \"chn_test.res\", line 82, characters 5-12", convert(" \b\t\n\v\f\ra"), { hd: 32, tl: { hd: 8, @@ -228,7 +228,7 @@ eq("File \"chn_test.ml\", line 84, characters 5-12", convert(" \b\t\n\v\f\ra"), } }); -eq("File \"chn_test.ml\", line 91, characters 6-13", convert(" \b\t\n\v\f\r\"'\\\0a"), { +eq("File \"chn_test.res\", line 89, characters 4-11", convert(" \b\t\n\v\f\r\"'\\\0a"), { hd: 32, tl: { hd: 8, diff --git a/jscomp/test/chn_test.ml b/jscomp/test/chn_test.ml deleted file mode 100644 index 4079785415..0000000000 --- a/jscomp/test/chn_test.ml +++ /dev/null @@ -1,94 +0,0 @@ -let suites : Mt.pair_suites ref = ref [] -let test_id = ref 0 -let eq loc x y = - incr test_id ; - suites := - (loc ^" id " ^ (string_of_int !test_id), (fun _ -> Mt.Eq(x,y))) :: !suites - -;; -Js.log {js|你好， -世界|js} -;; - -Js.log {js|\x3f\u003f\b\t\n\v\f\r\0"'|js} -;; -let convert (s : string) : int list = - Js_array2.fromMap - (Js_string.castToArrayLike s) - (fun x -> - match Js_string2.codePointAt x 0 with - | None -> assert false - | Some x -> x ) |> Array.to_list - -let () = - begin - eq __LOC__ {js|你好， -世界|js} {js|你好，\n世界|js}; - eq __LOC__ - (convert {js|汉字是世界上最美丽的character|js} ) - [27721; - 23383; - 26159; - 19990; - 30028; - 19978; - 26368; - 32654; - 20029; - 30340; - 99; - 104; - 97; - 114; - 97; - 99; - 116; - 101; - 114 ]; - eq __LOC__ (convert {js|\x3f\x3fa|js}) - [63;63;97]; - eq __LOC__ (convert {js|??a|js}) - [63;63;97]; - eq __LOC__ (convert {js|\u003f\x3fa|js}) - [63;63;97]; - eq __LOC__ (convert {js|🚀🚀a|js}) - [128640;128640;97]; - eq __LOC__ (convert {js|\uD83D\uDE80a|js}) - [128640; 97]; - eq __LOC__ (convert {js|\uD83D\uDE80\x3f|js}) - [128640; 63]; - - (* It is amazing Array.from(string) - is unicode safe *) - eq __LOC__ (convert {js|\uD83D\uDE80\uD83D\uDE80a|js}) - [128640; 128640; 97]; - - eq "No inline string length" (String.length {js|\uD83D\uDE80\0|js}) 3; - (** should not optimize - Note in JS, the length is also not unicode safe - *) - (* eq __LOC__ - (Js.String.codePointAt 0 {js|\uD83D\uDE80\0|js} ) 128640; *) - eq __LOC__ - ({js|\uD83D\uDE80\0|js}.[0] :> int) - (*TODO: Char.code need normalization? *) - 128640; - eq __LOC__ ({j|🚀|j}.[0] :> int) 128640; - - (* "\uD83D\uDE80".charCodeAt(0) & 255 - 61 *) - (** Note that [char] maximum is 255 *) - eq __LOC__ (convert {js|\uD83D\uDE80|js}) - [128640]; - eq __LOC__ (convert {js|\uD83D\uDE80\uD83D\uDE80|js}) [128640;128640]; - eq __LOC__ (convert {js| \b\t\n\v\f\ra|js}) - [ 32; 8; 9; 10; 11; 12; 13; 97]; - (* we don't need escape string double quote {|"|}and single quote{|'|} - however when we print it, we need escape them - there is no need for line continuation, - - *) - eq __LOC__ (convert {js| \b\t\n\v\f\r"'\\\0a|js}) - [ 32; 8; 9; 10; 11; 12; 13; 34; 39; 92;0 ;97] - end -let () = Mt.from_pair_suites __MODULE__ !suites \ No newline at end of file diff --git a/jscomp/test/chn_test.res b/jscomp/test/chn_test.res new file mode 100644 index 0000000000..3b6dba7d4e --- /dev/null +++ b/jscomp/test/chn_test.res @@ -0,0 +1,94 @@ +let suites: ref = ref(list{}) +let test_id = ref(0) +let eq = (loc, x, y) => { + incr(test_id) + suites := + list{(loc ++ (" id " ++ string_of_int(test_id.contents)), _ => Mt.Eq(x, y)), ...suites.contents} +} + +Js.log(`你好， +世界`) + +Js.log(`\x3f\u003f\b\t\n\v\f\r\0"'`) + +let convert = (s: string): list => + Js_array2.fromMap(Js_string.castToArrayLike(s), x => + switch Js_string2.codePointAt(x, 0) { + | None => assert false + | Some(x) => x + } + ) |> Array.to_list + +let () = { + eq( + __LOC__, + `你好， +世界`, + `你好，\n世界`, + ) + eq( + __LOC__, + convert(`汉字是世界上最美丽的character`), + list{ + 27721, + 23383, + 26159, + 19990, + 30028, + 19978, + 26368, + 32654, + 20029, + 30340, + 99, + 104, + 97, + 114, + 97, + 99, + 116, + 101, + 114, + }, + ) + eq(__LOC__, convert(`\x3f\x3fa`), list{63, 63, 97}) + eq(__LOC__, convert(`??a`), list{63, 63, 97}) + eq(__LOC__, convert(`\u003f\x3fa`), list{63, 63, 97}) + eq(__LOC__, convert(`🚀🚀a`), list{128640, 128640, 97}) + eq(__LOC__, convert(`\uD83D\uDE80a`), list{128640, 97}) + eq(__LOC__, convert(`\uD83D\uDE80\x3f`), list{128640, 63}) + + /* It is amazing Array.from(string) + is unicode safe */ + eq(__LOC__, convert(`\uD83D\uDE80\uD83D\uDE80a`), list{128640, 128640, 97}) + + eq("No inline string length", String.length(`\uD83D\uDE80\0`), 3) + + /* eq __LOC__ + (Js.String.codePointAt 0 {js|\uD83D\uDE80\0|js} ) 128640; */ + eq( + __LOC__, + (String.get(`\uD83D\uDE80\0`, 0) :> int), + /* TODO: Char.code need normalization? */ + 128640, + ) + eq(__LOC__, (String.get(`🚀`, 0) :> int), 128640) + + /* "\uD83D\uDE80".charCodeAt(0) & 255 + 61 */ + + eq(__LOC__, convert(`\uD83D\uDE80`), list{128640}) + eq(__LOC__, convert(`\uD83D\uDE80\uD83D\uDE80`), list{128640, 128640}) + eq(__LOC__, convert(` \b\t\n\v\f\ra`), list{32, 8, 9, 10, 11, 12, 13, 97}) + /* we don't need escape string double quote {|"|}and single quote{|'|} + however when we print it, we need escape them + there is no need for line continuation, + + */ + eq( + __LOC__, + convert(` \b\t\n\v\f\r"'\\\0a`), + list{32, 8, 9, 10, 11, 12, 13, 34, 39, 92, 0, 97}, + ) +} +let () = Mt.from_pair_suites(__MODULE__, suites.contents) diff --git a/jscomp/test/exception_def.js b/jscomp/test/exception_def.js index 1819161779..714829d2f4 100644 --- a/jscomp/test/exception_def.js +++ b/jscomp/test/exception_def.js @@ -1,7 +1,6 @@ 'use strict'; var Mt = require("./mt.js"); -var Printexc = require("../../lib/js/printexc.js"); var Caml_exceptions = require("../../lib/js/caml_exceptions.js"); var suites = { @@ -74,13 +73,6 @@ var h5 = { _1: "xx" }; -Printexc.register_printer(function (s) { - if (s.RE_EXN_ID === A) { - return "A"; - } - - }); - function p(e) { if (e.RE_EXN_ID === H4) { return 0; @@ -97,25 +89,25 @@ function p(e) { } } -eq("File \"exception_def.ml\", line 54, characters 6-13", p(h5), 0); +eq("File \"exception_def.ml\", line 50, characters 6-13", p(h5), 0); -eq("File \"exception_def.ml\", line 55, characters 6-13", p({ +eq("File \"exception_def.ml\", line 51, characters 6-13", p({ RE_EXN_ID: "Not_found" }), 4); -eq("File \"exception_def.ml\", line 56, characters 6-13", p({ +eq("File \"exception_def.ml\", line 52, characters 6-13", p({ RE_EXN_ID: H0 }), 4); -eq("File \"exception_def.ml\", line 57, characters 6-13", p({ +eq("File \"exception_def.ml\", line 53, characters 6-13", p({ RE_EXN_ID: H2 }), 1); -eq("File \"exception_def.ml\", line 58, characters 6-13", p({ +eq("File \"exception_def.ml\", line 54, characters 6-13", p({ RE_EXN_ID: H2 }), 1); -eq("File \"exception_def.ml\", line 59, characters 6-13", p({ +eq("File \"exception_def.ml\", line 55, characters 6-13", p({ RE_EXN_ID: "Invalid_argument", _1: "" }), 0); diff --git a/jscomp/test/exception_def.ml b/jscomp/test/exception_def.ml index 8e8118033f..f1cab67200 100644 --- a/jscomp/test/exception_def.ml +++ b/jscomp/test/exception_def.ml @@ -36,10 +36,6 @@ let h4 = H0 exception H4 = Invalid_argument let h5 = H4 "xx" -;; Printexc.register_printer (function - | A s -> Some "A" - | _ -> None -) let p e = match e with diff --git a/jscomp/test/exception_repr_test.js b/jscomp/test/exception_repr_test.js deleted file mode 100644 index 65cb701aab..0000000000 --- a/jscomp/test/exception_repr_test.js +++ /dev/null @@ -1,78 +0,0 @@ -'use strict'; - -var Mt = require("./mt.js"); -var Printexc = require("../../lib/js/printexc.js"); -var Exception_def = require("./exception_def.js"); -var Caml_exceptions = require("../../lib/js/caml_exceptions.js"); - -var suites = { - contents: /* [] */0 -}; - -var test_id = { - contents: 0 -}; - -function eq(loc, x, y) { - test_id.contents = test_id.contents + 1 | 0; - suites.contents = { - hd: [ - loc + (" id " + String(test_id.contents)), - (function (param) { - return { - TAG: /* Eq */0, - _0: x, - _1: y - }; - }) - ], - tl: suites.contents - }; -} - -var Hi = /* @__PURE__ */Caml_exceptions.create("Exception_repr_test.Hi"); - -var Hello = /* @__PURE__ */Caml_exceptions.create("Exception_repr_test.Hello"); - -var A = /* @__PURE__ */Caml_exceptions.create("Exception_repr_test.A"); - -Printexc.register_printer(function (s) { - if (s.RE_EXN_ID === Hi) { - return "hey"; - } else if (s.RE_EXN_ID === A) { - return "A(" + s._1 + ")"; - } else { - return ; - } - }); - -eq("File \"exception_repr_test.ml\", line 24, characters 7-14", "hey", Printexc.to_string({ - RE_EXN_ID: Hi - })); - -eq("File \"exception_repr_test.ml\", line 25, characters 7-14", "A(1)", Printexc.to_string({ - RE_EXN_ID: A, - _1: 1 - })); - -eq("File \"exception_repr_test.ml\", line 26, characters 7-14", Printexc.to_string({ - RE_EXN_ID: Hello - }).startsWith("Exception_repr_test.Hello"), true); - -eq("File \"exception_repr_test.ml\", line 27, characters 7-14", "A", Printexc.to_string({ - RE_EXN_ID: Exception_def.A, - _1: 3 - })); - -Mt.from_pair_suites("Exception_repr_test", suites.contents); - -var AAA = Exception_def.A; - -exports.suites = suites; -exports.test_id = test_id; -exports.eq = eq; -exports.Hi = Hi; -exports.Hello = Hello; -exports.A = A; -exports.AAA = AAA; -/* Not a pure module */ diff --git a/jscomp/test/exception_repr_test.ml b/jscomp/test/exception_repr_test.ml deleted file mode 100644 index 287ef4b045..0000000000 --- a/jscomp/test/exception_repr_test.ml +++ /dev/null @@ -1,31 +0,0 @@ -let suites : Mt.pair_suites ref = ref [] -let test_id = ref 0 -let eq loc x y = - incr test_id ; - suites := - (loc ^" id " ^ (string_of_int !test_id), (fun _ -> Mt.Eq(x,y))) :: !suites - - - -exception Hi -exception Hello -exception A of int -exception AAA = Exception_def.A - -;; Printexc.register_printer (function - | Hi -> Some "hey" - | A s -> Some ({j|A($(s))|j} ) - | _ -> None -) - - - -let () = - eq __LOC__ "hey" (Printexc.to_string Hi); - eq __LOC__ "A(1)" (Printexc.to_string (A 1)); - eq __LOC__ (Js.String2.startsWith (Printexc.to_string Hello) "Exception_repr_test.Hello") true; - eq __LOC__ "A" (Printexc.to_string @@ AAA 3) - -;; Mt.from_pair_suites __MODULE__ !suites - - diff --git a/jscomp/test/ext_filename_test.ml b/jscomp/test/ext_filename_test.ml index cb2896323a..57b50c9b34 100644 --- a/jscomp/test/ext_filename_test.ml +++ b/jscomp/test/ext_filename_test.ml @@ -82,7 +82,7 @@ let chop_extension ?(loc="") name = try Filename.chop_extension name with Invalid_argument _ -> invalid_arg - {j|Filename.chop_extension ( $(loc) : $(name) )|j} + (((("Filename.chop_extension ( " ^ loc) ^ " : ") ^ name) ^ " )") let chop_extension_if_any fname = try Filename.chop_extension fname with Invalid_argument _ -> fname @@ -159,7 +159,7 @@ let node_relative_path node_modules_shorten (file1 : t) let rec skip i = if i >= len then - failwith {j|invalid path: $(file2)|j} + failwith ("invalid path: " ^ file2) else (* https://en.wikipedia.org/wiki/Path_(computing)) most path separator are a single char @@ -202,7 +202,7 @@ let rec find_root_filename ~cwd filename = find_root_filename ~cwd:cwd' filename else failwith - {j|$(filename) not found from $(cwd)|j} + ((("" ^ filename) ^ " not found from ") ^ cwd) let find_package_json_dir cwd = diff --git a/jscomp/test/float_of_bits_test.ml b/jscomp/test/float_of_bits_test.ml index 2e59994abc..9efb9c85ef 100644 --- a/jscomp/test/float_of_bits_test.ml +++ b/jscomp/test/float_of_bits_test.ml @@ -9,8 +9,8 @@ let int32_pairs = let from_pairs pair = int32_pairs |> Array.mapi (fun i (i32, f) -> - [ {j|int32_float_of_bits $(i)|j} , (fun _ -> Mt.Eq (Int32.float_of_bits i32, f)); - {j|int32_bits_of_float $(i)|j} , (fun _ -> Mt.Eq (Int32.bits_of_float f, i32)); + [ "int32_float_of_bits " ^ (__unsafe_cast i) , (fun _ -> Mt.Eq (Int32.float_of_bits i32, f)); + "int32_bits_of_float " ^ (__unsafe_cast i), (fun _ -> Mt.Eq (Int32.bits_of_float f, i32)); ] ) |> Array.to_list |> List.concat let suites = Mt.[ diff --git a/jscomp/test/float_test.ml b/jscomp/test/float_test.ml index 91afad4589..ceaf19cb60 100644 --- a/jscomp/test/float_test.ml +++ b/jscomp/test/float_test.ml @@ -37,7 +37,7 @@ let results = let from_pairs ps = ps - |> Array.mapi (fun i (a,b) -> {j|pair $(i)|j} , (fun _ -> Mt.Approx(a,b))) + |> Array.mapi (fun i (a,b) -> "pair " ^ (__unsafe_cast i), (fun _ -> Mt.Approx(a,b))) |> Array.to_list ;; diff --git a/jscomp/test/gpr_1501_test.js b/jscomp/test/gpr_1501_test.js deleted file mode 100644 index b3e6d2c727..0000000000 --- a/jscomp/test/gpr_1501_test.js +++ /dev/null @@ -1,56 +0,0 @@ -'use strict'; - -var Mt = require("./mt.js"); -var Printexc = require("../../lib/js/printexc.js"); -var Caml_exceptions = require("../../lib/js/caml_exceptions.js"); - -var suites = { - contents: /* [] */0 -}; - -var test_id = { - contents: 0 -}; - -function eq(loc, x, y) { - test_id.contents = test_id.contents + 1 | 0; - suites.contents = { - hd: [ - loc + (" id " + String(test_id.contents)), - (function (param) { - return { - TAG: /* Eq */0, - _0: x, - _1: y - }; - }) - ], - tl: suites.contents - }; -} - -var A = /* @__PURE__ */Caml_exceptions.create("Gpr_1501_test.A"); - -var B = /* @__PURE__ */Caml_exceptions.create("Gpr_1501_test.B"); - -eq("File \"gpr_1501_test.ml\", line 15, characters 7-14", "Not_found", Printexc.to_string({ - RE_EXN_ID: "Not_found" - })); - -eq("File \"gpr_1501_test.ml\", line 16, characters 7-14", /Gpr_1501_test.A\/[0-9]+/.test(Printexc.to_string({ - RE_EXN_ID: A - })), true); - -eq("File \"gpr_1501_test.ml\", line 19, characters 7-14", /Gpr_1501_test.B\/[0-9]+\(1\)/.test(Printexc.to_string({ - RE_EXN_ID: B, - _1: 1 - })), true); - -Mt.from_pair_suites("Gpr_1501_test", suites.contents); - -exports.suites = suites; -exports.test_id = test_id; -exports.eq = eq; -exports.A = A; -exports.B = B; -/* Not a pure module */ diff --git a/jscomp/test/gpr_1501_test.ml b/jscomp/test/gpr_1501_test.ml deleted file mode 100644 index e586daa45b..0000000000 --- a/jscomp/test/gpr_1501_test.ml +++ /dev/null @@ -1,23 +0,0 @@ - -let suites : Mt.pair_suites ref = ref [] -let test_id = ref 0 -let eq loc x y = - incr test_id ; - suites := - (loc ^" id " ^ (string_of_int !test_id), (fun _ -> Mt.Eq(x,y))) :: !suites - - -exception A -exception B of int - -let () = - - eq __LOC__ "Not_found" (Printexc.to_string Not_found); - eq __LOC__ - (Js.Re.test_ [%re{|/Gpr_1501_test.A\/[0-9]+/|}] (Printexc.to_string A)) - true; - eq __LOC__ - (Js.Re.test_ [%re{|/Gpr_1501_test.B\/[0-9]+\(1\)/|}] (Printexc.to_string (B 1))) true - -let () = - Mt.from_pair_suites __MODULE__ !suites \ No newline at end of file diff --git a/jscomp/test/gpr_3142_test.js b/jscomp/test/gpr_3142_test.js index 93c3b468cd..783ef23143 100644 --- a/jscomp/test/gpr_3142_test.js +++ b/jscomp/test/gpr_3142_test.js @@ -26,23 +26,23 @@ function tFromJs(param) { return _revMap[param]; } -eq("File \"gpr_3142_test.ml\", line 25, characters 6-13", tToJs("a"), "x"); +eq("File \"gpr_3142_test.res\", line 17, characters 3-10", tToJs("a"), "x"); -eq("File \"gpr_3142_test.ml\", line 26, characters 6-13", tToJs("u"), "hi"); +eq("File \"gpr_3142_test.res\", line 18, characters 3-10", tToJs("u"), "hi"); -eq("File \"gpr_3142_test.ml\", line 27, characters 6-13", tToJs("b"), "你"); +eq("File \"gpr_3142_test.res\", line 19, characters 3-10", tToJs("b"), "你"); -eq("File \"gpr_3142_test.ml\", line 28, characters 6-13", tToJs("c"), "我"); +eq("File \"gpr_3142_test.res\", line 20, characters 3-10", tToJs("c"), "我"); -eq("File \"gpr_3142_test.ml\", line 30, characters 6-13", tFromJs("x"), "a"); +eq("File \"gpr_3142_test.res\", line 22, characters 3-10", tFromJs("x"), "a"); -eq("File \"gpr_3142_test.ml\", line 31, characters 6-13", tFromJs("hi"), "u"); +eq("File \"gpr_3142_test.res\", line 23, characters 3-10", tFromJs("hi"), "u"); -eq("File \"gpr_3142_test.ml\", line 32, characters 6-13", tFromJs("你"), "b"); +eq("File \"gpr_3142_test.res\", line 24, characters 3-10", tFromJs("你"), "b"); -eq("File \"gpr_3142_test.ml\", line 33, characters 6-13", tFromJs("我"), "c"); +eq("File \"gpr_3142_test.res\", line 25, characters 3-10", tFromJs("我"), "c"); -eq("File \"gpr_3142_test.ml\", line 34, characters 6-13", tFromJs("xx"), undefined); +eq("File \"gpr_3142_test.res\", line 26, characters 3-10", tFromJs("xx"), undefined); Mt.from_pair_suites("Gpr_3142_test", suites.contents); diff --git a/jscomp/test/gpr_3142_test.ml b/jscomp/test/gpr_3142_test.ml deleted file mode 100644 index 0006d35d1f..0000000000 --- a/jscomp/test/gpr_3142_test.ml +++ /dev/null @@ -1,36 +0,0 @@ -let suites : Mt.pair_suites ref = ref [] -let test_id = ref 0 -let eq loc x y = Mt.eq_suites ~test_id ~suites loc x y - - -type t = - [ `a [@bs.as "x"] - | `u [@bs.as "hi"] - | `b [@bs.as {j|你|j} ] - | `c [@bs.as {js|我|js}] - ] - [@@bs.deriving jsConverter] - -let v,u = tToJs, tFromJs - - -(* not applicable to thiis type, and unused warning*) -#if 0 then -type t0 = - [ `a of int [@bs.as "hi"] ] - [@@bs.deriving jsConverter] -#end - - -;; eq __LOC__ (v `a) "x" -;; eq __LOC__ (v `u) "hi" -;; eq __LOC__ (v `b) {j|你|j} -;; eq __LOC__ (v `c) {js|我|js} - -;; eq __LOC__ (u "x") (Some `a) -;; eq __LOC__ (u "hi") (Some `u) -;; eq __LOC__ (u {j|你|j}) (Some `b) -;; eq __LOC__ (u {js|我|js}) (Some `c) -;; eq __LOC__ (u "xx") None - -let () = Mt.from_pair_suites __MODULE__ !suites \ No newline at end of file diff --git a/jscomp/test/gpr_3142_test.res b/jscomp/test/gpr_3142_test.res new file mode 100644 index 0000000000..357943c588 --- /dev/null +++ b/jscomp/test/gpr_3142_test.res @@ -0,0 +1,28 @@ +let suites: ref = ref(list{}) +let test_id = ref(0) +let eq = (loc, x, y) => Mt.eq_suites(~test_id, ~suites, loc, x, y) + +@deriving(jsConverter) +type t = [ + | @as("x") #a + | @as("hi") #u + | @as(`你`) #b + | @as(`我`) #c +] + +let (v, u) = (tToJs, tFromJs) + +/* not applicable to thiis type, and unused warning */ + +eq(__LOC__, v(#a), "x") +eq(__LOC__, v(#u), "hi") +eq(__LOC__, v(#b), `你`) +eq(__LOC__, v(#c), `我`) + +eq(__LOC__, u("x"), Some(#a)) +eq(__LOC__, u("hi"), Some(#u)) +eq(__LOC__, u(`你`), Some(#b)) +eq(__LOC__, u(`我`), Some(#c)) +eq(__LOC__, u("xx"), None) + +let () = Mt.from_pair_suites(__MODULE__, suites.contents) diff --git a/jscomp/test/inline_const.js b/jscomp/test/inline_const.js index 6c8a9f25ee..203a5b96f6 100644 --- a/jscomp/test/inline_const.js +++ b/jscomp/test/inline_const.js @@ -3,6 +3,8 @@ var N = {}; +var hh = "hellohello"; + console.log([ 3e-6, 3e-6 @@ -16,8 +18,6 @@ function N1(funarg) { var h = "hello"; -var hh = "hellohello"; - exports.x = x; exports.N = N; exports.N1 = N1; diff --git a/jscomp/test/inline_const.ml b/jscomp/test/inline_const.ml deleted file mode 100644 index ca0a0a5f85..0000000000 --- a/jscomp/test/inline_const.ml +++ /dev/null @@ -1,47 +0,0 @@ - - -let x = true [@@bs.inline] - -let f = "hello" [@@bs.inline] - -let f1 = {j|a|j} [@@bs.inline] - -let f2 = {j|中文|j} [@@bs.inline] -(* Do we need fix - let f2 : string = blabla -*) - -module N : sig - val f3 : string [@@bs.inline {j|中文|j} ] -end = struct - let f3 = {j|中文|j} [@@bs.inline] -end - -module N1 = functor () -> struct - let f4 = {j|中文|j} [@@bs.inline] - let xx = 3e-6 [@@bs.inline] - let xx0 = 3e-6 -end -let h = f - -let hh = f ^ f - -open N - -module H = N1 () -open H -let a,b,c,d,e = - f,f1,f2,f3,f4 - -let f5 = true [@@bs.inline] - -let f6 = 1 [@@bs.inline] - -let f7 = 1L [@@bs.inline] - -let f9 = 100L [@@bs.inline] - -let v = 100L [@@bs.inline] -let u = 1L [@@bs.inline] - -let () = Js.log (xx,xx0) \ No newline at end of file diff --git a/jscomp/test/inline_const.mli b/jscomp/test/inline_const.mli deleted file mode 100644 index 4d2783326a..0000000000 --- a/jscomp/test/inline_const.mli +++ /dev/null @@ -1,34 +0,0 @@ -val x : bool - -val f : string [@@bs.inline "hello"] - -val f1 : - string -[@@bs.inline {j|a|j}] - -val f2 : - string -[@@bs.inline {j|中文|j}] - -module N : sig - val f3 : string [@@bs.inline {j|中文|j} ] -end - - -module N1 : functor () -> sig - val f4 : string - [@@bs.inline {j|中文|j}] - val xx : float [@@bs.inline 3e-6] -end - -val h : string -val hh : string - -val f5 : bool [@@bs.inline true ] - -val f6 : int [@@bs.inline 1] - -(* val f7 : bool [@@bs.inline 1L] *) - -val v : int64 [@@bs.inline 100L] -val u : int64 [@@bs.inline 1L ] diff --git a/jscomp/test/inline_const.res b/jscomp/test/inline_const.res new file mode 100644 index 0000000000..d7c9e42cba --- /dev/null +++ b/jscomp/test/inline_const.res @@ -0,0 +1,44 @@ +@inline let x = true + +@inline let f = "hello" + +@inline let f1 = `a` + +@inline let f2 = `中文` +/* Do we need fix + let f2 : string = blabla +*/ + +module N: { + @inline(`中文`) let f3: string +} = { + @inline let f3 = `中文` +} + +module N1 = () => { + @inline let f4 = `中文` + @inline let xx = 3e-6 + let xx0 = 3e-6 +} +let h = f + +let hh = f ++ f + +open N + +module H = N1() +open H +let (a, b, c, d, e) = (f, f1, f2, f3, f4) + +@inline let f5 = true + +@inline let f6 = 1 + +@inline let f7 = 1L + +@inline let f9 = 100L + +@inline let v = 100L +@inline let u = 1L + +let () = Js.log((xx, xx0)) diff --git a/jscomp/test/inline_const.resi b/jscomp/test/inline_const.resi new file mode 100644 index 0000000000..3e392f69b2 --- /dev/null +++ b/jscomp/test/inline_const.resi @@ -0,0 +1,29 @@ +let x: bool + +@inline("hello") let f: string + +@inline(`a`) let f1: string + +@inline(`中文`) let f2: string + +module N: { + @inline(`中文`) let f3: string +} + +module N1: () => +{ + @inline(`中文`) let f4: string + @inline(3e-6) let xx: float +} + +let h: string +let hh: string + +@inline(true) let f5: bool + +@inline(1) let f6: int + +/* val f7 : bool [@@bs.inline 1L] */ + +@inline(100L) let v: int64 +@inline(1L) let u: int64 diff --git a/jscomp/test/inline_const_test.js b/jscomp/test/inline_const_test.js index dbf9126506..e8f2dd6a49 100644 --- a/jscomp/test/inline_const_test.js +++ b/jscomp/test/inline_const_test.js @@ -29,28 +29,28 @@ var f3 = "中文"; var f4 = "中文"; -eq("File \"inline_const_test.ml\", line 29, characters 5-12", f, "hello"); +eq("File \"inline_const_test.res\", line 13, characters 5-12", f, "hello"); -eq("File \"inline_const_test.ml\", line 30, characters 5-12", f1, "a"); +eq("File \"inline_const_test.res\", line 14, characters 5-12", f1, "a"); -eq("File \"inline_const_test.ml\", line 31, characters 5-12", f2, "中文"); +eq("File \"inline_const_test.res\", line 15, characters 5-12", f2, "中文"); -eq("File \"inline_const_test.ml\", line 32, characters 5-12", f3, "中文"); +eq("File \"inline_const_test.res\", line 16, characters 5-12", f3, "中文"); -eq("File \"inline_const_test.ml\", line 33, characters 5-12", f4, "中文"); +eq("File \"inline_const_test.res\", line 17, characters 5-12", f4, "中文"); -eq("File \"inline_const_test.ml\", line 34, characters 5-12", true, true); +eq("File \"inline_const_test.res\", line 18, characters 5-12", true, true); -eq("File \"inline_const_test.ml\", line 35, characters 5-12", 1, 1); +eq("File \"inline_const_test.res\", line 19, characters 5-12", 1, 1); -eq("File \"inline_const_test.ml\", line 36, characters 5-12", 3e-6, 0.000003); +eq("File \"inline_const_test.res\", line 20, characters 5-12", 3e-6, 0.000003); var h = Caml_int64.add(Caml_int64.add([ 0, 100 ], Int64.one), Caml_int64.one); -Mt.from_pair_suites("File \"inline_const_test.ml\", line 43, characters 22-29", suites.contents); +Mt.from_pair_suites("File \"inline_const_test.res\", line 28, characters 29-36", suites.contents); var f5 = true; diff --git a/jscomp/test/inline_const_test.ml b/jscomp/test/inline_const_test.ml deleted file mode 100644 index 2e413612fd..0000000000 --- a/jscomp/test/inline_const_test.ml +++ /dev/null @@ -1,43 +0,0 @@ -let suites : Mt.pair_suites ref = ref [] -let test_id = ref 0 -let eq loc x y = Mt.eq_suites ~test_id ~suites loc x y - -module H = Inline_const.N1 (struct end) - -let f , - f1 , - f2, - f3, - f4, - f5, - f6, - f7 - = - - Inline_const.( - f , - f1 , - f2 , - N.f3, - H.f4, - f5, - f6, - H.xx - ) - -let () = - eq __LOC__ f "hello"; - eq __LOC__ f1 "a"; - eq __LOC__ f2 {j|中文|j}; - eq __LOC__ f3 {j|中文|j}; - eq __LOC__ f4 {j|中文|j}; - eq __LOC__ f5 true; - eq __LOC__ f6 1 ; - eq __LOC__ f7 0.000003 - -let h = - let open Inline_const in - Int64.add (Int64.add v Int64.one) u - -let () = - Mt.from_pair_suites __LOC__ !suites \ No newline at end of file diff --git a/jscomp/test/inline_const_test.res b/jscomp/test/inline_const_test.res new file mode 100644 index 0000000000..64ca4c3579 --- /dev/null +++ b/jscomp/test/inline_const_test.res @@ -0,0 +1,28 @@ +let suites: ref = ref(list{}) +let test_id = ref(0) +let eq = (loc, x, y) => Mt.eq_suites(~test_id, ~suites, loc, x, y) + +module H = Inline_const.N1() + +let (f, f1, f2, f3, f4, f5, f6, f7) = { + open Inline_const + (f, f1, f2, N.f3, H.f4, f5, f6, H.xx) +} + +let () = { + eq(__LOC__, f, "hello") + eq(__LOC__, f1, "a") + eq(__LOC__, f2, `中文`) + eq(__LOC__, f3, `中文`) + eq(__LOC__, f4, `中文`) + eq(__LOC__, f5, true) + eq(__LOC__, f6, 1) + eq(__LOC__, f7, 0.000003) +} + +let h = { + open Inline_const + Int64.add(Int64.add(v, Int64.one), u) +} + +let () = Mt.from_pair_suites(__LOC__, suites.contents) diff --git a/jscomp/test/int32_test.ml b/jscomp/test/int32_test.ml index 78956684eb..e360e9acae 100644 --- a/jscomp/test/int32_test.ml +++ b/jscomp/test/int32_test.ml @@ -31,13 +31,13 @@ let suites = ref (Mt.[ __LOC__, (fun _ -> Eq (0xffff_ffffl *~ 0xffff_ffffl, 1l)); __LOC__, (fun _ -> Eq (0xffff_ffffl *~ 0x7fff_ffffl, -2147483647l)) ] @ ((let (a,b) = shift_right_logical_tests in - Ext_array_test.map2i (fun i a b -> {j|shift_right_logical_cases $(i)|j} , (fun _ -> Mt.Eq(a,b)) ) a b + Ext_array_test.map2i (fun i a b -> "shift_right_logical_cases " ^ (__unsafe_cast i), (fun _ -> Mt.Eq(a,b)) ) a b |> Array.to_list)) @ ((let (a,b) = shift_right_tests in - Ext_array_test.map2i (fun i a b -> {j|shift_right_cases $(i)|j} , (fun _ -> Mt.Eq(a,b)) ) a b + Ext_array_test.map2i (fun i a b -> "shift_right_cases " ^ (__unsafe_cast i), (fun _ -> Mt.Eq(a,b)) ) a b |> Array.to_list)) @ ((let (a,b) = shift_left_tests in - Ext_array_test.map2i (fun i a b -> {j|shift_left_cases $(i)|j}, (fun _ -> Mt.Eq(a,b)) ) a b + Ext_array_test.map2i (fun i a b -> "shift_left_cases " ^ (__unsafe_cast i), (fun _ -> Mt.Eq(a,b)) ) a b |> Array.to_list))) let test_id = ref 0 diff --git a/jscomp/test/int64_mul_div_test.ml b/jscomp/test/int64_mul_div_test.ml index 3712832e5e..948977a27b 100644 --- a/jscomp/test/int64_mul_div_test.ml +++ b/jscomp/test/int64_mul_div_test.ml @@ -26,7 +26,7 @@ let pairs = [|(-6369178941122375200L, 7864955043652308640L, 710079015173034099L) let from_pairs prefix pairs = (Array.to_list @@ Array.mapi (fun i (result,a,b) -> - ( {j|$(prefix)_$(i)|j} ) , fun _ -> commutative_mul result a b) pairs) + ((("" ^ prefix) ^ "_") ^ (__unsafe_cast i) ) , fun _ -> commutative_mul result a b) pairs) let small_pairs = [| 121L, 11L, 11L; @@ -159,7 +159,7 @@ let from xs = xs |> Array.to_list |> List.mapi (fun i (a , b, c, d) -> - ({j|small_divs $i|j} ), + ("small_divs " ^ (__unsafe_cast i)), (fun _ -> Mt.Eq ((c, d), (Int64.div a b, Int64.rem a b ) ))) let to_string = [| 0L, "0" @@ -176,7 +176,7 @@ let from_compare xs = xs |> Array.to_list |> List.mapi (fun i (a, b,c) -> - ({j|int64_compare $i|j} ), + ("int64_compare " ^ (__unsafe_cast i)), (fun _ -> Mt.Eq(c, Int64.compare a b)) ) @@ -184,7 +184,7 @@ let from_to_string xs = xs |> Array.to_list |> List.mapi (fun i (a, str_a) -> - ({j|to_string $i|j} ), + ("to_string " ^ (__unsafe_cast i)), (fun _ -> Mt.Eq(str_a, Int64.to_string a)) ) @@ -193,10 +193,10 @@ let from_to_string xs = from_pairs "small" small_pairs @ (to_floats |> Array.to_list |> List.mapi (fun i (i64, f) -> - ({j|to_float_$i|j} ), (fun _ -> Mt.Eq(Int64.to_float i64, f)) + ("to_float_" ^ (__unsafe_cast i)), (fun _ -> Mt.Eq(Int64.to_float i64, f)) )) @ (of_float_pairs |> Array.to_list |> List.mapi (fun i (f, i64) -> - ({j|of_float_$i|j} ), (fun _ -> Mt.Eq(Int64.of_float f, i64)) + ("of_float_" ^ (__unsafe_cast i)), (fun _ -> Mt.Eq(Int64.of_float f, i64)) )) @ [ "compare_check_complete", diff --git a/jscomp/test/int64_test.ml b/jscomp/test/int64_test.ml index c146d0ee2b..b160be149e 100644 --- a/jscomp/test/int64_test.ml +++ b/jscomp/test/int64_test.ml @@ -172,14 +172,14 @@ let suites : Mt.pair_suites = Mt.[ ) ] @ (let (a,b) = shift_left_tests in - Ext_array_test.map2i (fun i a b -> {j|shift_left_cases $(i)|j}, (fun _ -> Mt.Eq(a,b)) ) a b + Ext_array_test.map2i (fun i a b -> "shift_left_cases " ^ (__unsafe_cast i), (fun _ -> Mt.Eq(a,b)) ) a b |> Array.to_list) @ ((let (a,b) = shift_right_tests in - Ext_array_test.map2i (fun i a b -> {j|shift_right_cases $(i)|j}, (fun _ -> Mt.Eq(a,b)) ) a b + Ext_array_test.map2i (fun i a b -> "shift_right_cases " ^ (__unsafe_cast i), (fun _ -> Mt.Eq(a,b)) ) a b |> Array.to_list)) @ ((let (a,b) = shift_right_logical_suites in - Ext_array_test.map2i (fun i a b -> {j|shift_right_logical_cases $(i)|j}, (fun _ -> Mt.Eq(a,b)) ) a b + Ext_array_test.map2i (fun i a b -> "shift_right_logical_cases " ^ (__unsafe_cast i), (fun _ -> Mt.Eq(a,b)) ) a b |> Array.to_list)) diff --git a/jscomp/test/libarg_test.js b/jscomp/test/libarg_test.js index 6ef3d1f98f..9cddecb871 100644 --- a/jscomp/test/libarg_test.js +++ b/jscomp/test/libarg_test.js @@ -297,13 +297,12 @@ var args2 = [ ]; function error(s) { - console.log("error (%s)"); + console.log("error (" + (s + ")")); } function check(r, v, msg) { if (Caml_obj.notequal(r.contents, v)) { - console.log("error (%s)"); - return ; + return error(msg); } } diff --git a/jscomp/test/libarg_test.ml b/jscomp/test/libarg_test.ml index 0cf2fdb2d3..44baee0ed4 100644 --- a/jscomp/test/libarg_test.ml +++ b/jscomp/test/libarg_test.ml @@ -7,18 +7,18 @@ let record fmt (* args *) = ;; let f_unit () = record "unit()";; -let f_bool b = record {j|bool($b)|j};; +let f_bool b = record (("bool(" ^ (__unsafe_cast b)) ^ ")");; let r_set = ref false;; let r_clear = ref true;; -let f_string s = record {j|string($s)|j};; +let f_string s = record (("string(" ^ s) ^ ")");; let r_string = ref "";; -let f_int i = record {j|int($i)|j} ;; +let f_int i = record (("int(" ^ (__unsafe_cast i)) ^ ")") ;; let r_int = ref 0;; -let f_float f = record {j|float($f)|j};; +let f_float f = record (("float(" ^ (__unsafe_cast f)) ^ ")");; let r_float = ref 0.0;; -let f_symbol s = record {j|symbol($s)|j} ;; -let f_rest s = record {j|rest($s)|j} ;; -let f_anon s = record {j|anon($s)|j} ;; +let f_symbol s = record (("symbol(" ^ s) ^ ")") ;; +let f_rest s = record (("rest(" ^ s) ^ ")") ;; +let f_anon s = record (("anon(" ^ s) ^ ")") ;; let spec = Arg.[ "-u", Unit f_unit, "Unit (0)"; @@ -78,7 +78,7 @@ let args2 = [| "-rest"; "r1"; "r2"; |];; -let error s = Js.log {j|error (%s)|j} +let error s = Js.log ("error (" ^ s ^ ")") let check r v msg = if !r <> v then error msg;; let test argv = diff --git a/jscomp/test/mario_game.js b/jscomp/test/mario_game.js index d33380e291..d9c6052b01 100644 --- a/jscomp/test/mario_game.js +++ b/jscomp/test/mario_game.js @@ -149,8 +149,8 @@ function make_enemy(param) { } } -function make_particle(param) { - switch (param) { +function make_particle(x) { + switch (x) { case /* GoombaSquish */0 : return setup_sprite(undefined, undefined, undefined, "enemies.png", 1, 0, [ 16, @@ -504,8 +504,8 @@ function make_type(typ, dir) { dir ]); case /* SItem */2 : - var param = typ._0; - switch (param) { + var x = typ._0; + switch (x) { case /* Mushroom */0 : return setup_sprite(undefined, [ 2, @@ -553,8 +553,8 @@ function make_type(typ, dir) { } case /* SBlock */3 : - var param$1 = typ._0; - if (typeof param$1 !== "number") { + var x$1 = typ._0; + if (typeof x$1 !== "number") { return setup_sprite(undefined, undefined, undefined, "blocks.png", 4, 15, [ 16, 16 @@ -563,7 +563,7 @@ function make_type(typ, dir) { 16 ]); } - switch (param$1) { + switch (x$1) { case /* QBlockUsed */0 : return setup_sprite(undefined, undefined, undefined, "blocks.png", 1, 0, [ 16, @@ -808,20 +808,20 @@ function set_vel_to_speed(obj) { } } -function make_type$2(t) { - switch (t.TAG | 0) { +function make_type$2(x) { + switch (x.TAG | 0) { case /* SPlayer */0 : return setup_obj(undefined, 2.8, undefined); case /* SEnemy */1 : - var param = t._0; - if (param >= 3) { + var x$1 = x._0; + if (x$1 >= 3) { return setup_obj(undefined, 3, undefined); } else { return setup_obj(undefined, undefined, undefined); } case /* SItem */2 : - var param$1 = t._0; - if (param$1 >= 3) { + var x$2 = x._0; + if (x$2 >= 3) { return setup_obj(false, undefined, undefined); } else { return setup_obj(undefined, undefined, undefined); @@ -910,24 +910,24 @@ function spawn(spawnable, context, param) { } } -function get_sprite(param) { - return param._1; +function get_sprite(x) { + return x._1; } -function get_obj(param) { - return param._2; +function get_obj(x) { + return x._2; } -function is_player(param) { - if (param.TAG === /* Player */0) { +function is_player(x) { + if (x.TAG === /* Player */0) { return true; } else { return false; } } -function is_enemy(param) { - if (param.TAG === /* Enemy */1) { +function is_enemy(x) { + if (x.TAG === /* Enemy */1) { return true; } else { return false; @@ -3213,7 +3213,7 @@ function load(param) { if (el !== null) { canvas = el; } else { - console.log("cant find canvas " + canvas_id + " "); + console.log("cant find canvas " + canvas_id + ""); throw { RE_EXN_ID: "Failure", _1: "fail", diff --git a/jscomp/test/mario_game.ml b/jscomp/test/mario_game.ml deleted file mode 100644 index 90dfdcb1fc..0000000000 --- a/jscomp/test/mario_game.ml +++ /dev/null @@ -1,2040 +0,0 @@ -[@@@bs.config {flags = [|"-w";"a";"-bs-no-bin-annot"|]}] - -module Actors : sig -#1 "actors.mli" -type dir_1d = | Left | Right -type dir_2d = | North | South | East | West - -(* Generic xy record for easy position access *) -type xy = { - mutable x: float; - mutable y: float; -} - -(* Controls correspond to keyboard input *) -type controls = - | CLeft - | CRight - | CUp - | CDown - -(* Player ability type *) -type pl_typ = - | BigM - | SmallM - -type item_typ = - | Mushroom - | FireFlower - | Star - | Coin - -type enemy_typ = - | Goomba - | GKoopa - | RKoopa - | GKoopaShell - | RKoopaShell - -type block_typ = - | QBlock of item_typ - | QBlockUsed - | Brick - | UnBBlock - | Cloud - | Panel - | Ground - -(* Player action type *) -type player_typ = - | Standing - | Jumping - | Running - | Crouching - -(* Particle Type *) -type part_typ = - | GoombaSquish - | BrickChunkL - | BrickChunkR - | Score100 - | Score200 - | Score400 - | Score800 - | Score1000 - | Score2000 - | Score4000 - | Score8000 - -(*type unbblock_typ = - | Wood - | Earth - | Brick -| *) - -type spawn_typ = - | SPlayer of pl_typ * player_typ - | SEnemy of enemy_typ - | SItem of item_typ - | SBlock of block_typ - (*| SGround of ground_typ*) - - -end = struct -#1 "actors.ml" -type dir_1d = | Left | Right -type dir_2d = | North | South | East | West - -type xy = { - mutable x: float; - mutable y: float; -} - -type controls = - | CLeft - | CRight - | CUp - | CDown - -type pl_typ = - | BigM - | SmallM - -type item_typ = - | Mushroom - | FireFlower - | Star - | Coin - -type enemy_typ = - | Goomba - | GKoopa - | RKoopa - | GKoopaShell - | RKoopaShell - -type block_typ = - | QBlock of item_typ - | QBlockUsed - | Brick - | UnBBlock - | Cloud - | Panel - | Ground - -type player_typ = - | Standing - | Jumping - | Running - | Crouching - -type part_typ = - | GoombaSquish - | BrickChunkL - | BrickChunkR - | Score100 - | Score200 - | Score400 - | Score800 - | Score1000 - | Score2000 - | Score4000 - | Score8000 - -type spawn_typ = - | SPlayer of pl_typ * player_typ - | SEnemy of enemy_typ - | SItem of item_typ - | SBlock of block_typ -end -module Dom_html -= struct -#153 "mario_game.ml" -type imageElement -type canvasRenderingContext2D -type canvasElement - -external document: Dom.document = "document" [@@bs.val] -external window: Dom.window = "window" [@@bs.val] - -(* external createImg: (_ [@bs.as "img"]) -> document -> imageElement = "createElement" [@@bs.send] *) -external createImg: Dom.document -> (_ [@bs.as "img"]) -> imageElement = "createElement" [@@bs.send] -external requestAnimationFrame : (float -> unit) -> unit = "requestAnimationFrame"[@@bs.val ] -external getElementById : Dom.document -> string -> Dom.element option = "getElementById"[@@bs.return null_to_opt][@@bs.send] -external addEventListener : Dom.document -> string -> ('a Dom.event_like -> bool) -> bool -> unit = "addEventListener" [@@bs.send] -external addEventListenerImg : imageElement -> string -> ('a Dom.event_like -> bool) -> bool -> unit = "addEventListener" [@@bs.send] - -(* unsafe casts *) -external imageElementToJsObj : imageElement -> < .. > = "%identity" -external canvasRenderingContext2DToJsObj : canvasRenderingContext2D -> < .. > = "%identity" -external canvasElementToJsObj : canvasElement -> < .. > = "%identity" -external keyboardEventToJsObj : Dom.keyboardEvent -> < .. > = "%identity" -external elementToCanvasElement : Dom.element -> canvasElement = "%identity" -external windowToJsObj : Dom.window -> < .. > = "%identity" - - -end -module Sprite : sig -#1 "sprite.mli" -open Actors - -(* Represents an xy vector *) -type xy = float * float (* x, y *) - -(* Inherent sprite parameters from which to create the sprite *) -type sprite_params = - { - max_frames: int; - max_ticks: int; - img_src: string; - frame_size: xy; - src_offset: xy; - bbox_offset: xy; - bbox_size: xy; - loop: bool; - } - -(* Concrete sprite created to visually represent an object *) -type sprite = - { - mutable params: sprite_params; - context: Dom_html.canvasRenderingContext2D; - frame: int ref; - ticks: int ref; - mutable img: Dom_html.imageElement; - } - - -(* Sets up a sprite to create *) -val setup_sprite : ?loop:bool -> ?bb_off:float*float-> ?bb_sz:float*float - -> string -> int -> int -> xy -> xy - -> sprite_params - -(* Creates a sprite given the actor type *) -val make : Actors.spawn_typ -> Actors.dir_1d - -> Dom_html.canvasRenderingContext2D - -> sprite - -(* Make a background *) -val make_bgd : Dom_html.canvasRenderingContext2D -> sprite - -(* Make a particle corresponding to the given type *) -val make_particle : Actors.part_typ - -> Dom_html.canvasRenderingContext2D -> sprite - -(* Transform an enemy sprite based on direction *) -val transform_enemy : Actors.enemy_typ -> sprite -> Actors.dir_1d -> unit - -(* Updates the sprite's animation *) -val update_animation : sprite -> unit - - -end = struct -#1 "sprite.ml" -open Actors - -type xy = float * float - -type sprite_params = - { - max_frames: int; - max_ticks: int; - img_src: string; - frame_size: xy; - src_offset: xy; - bbox_offset: xy; - bbox_size: xy; - loop: bool; - } - -type sprite = - { - mutable params: sprite_params; - context: Dom_html.canvasRenderingContext2D; - frame: int ref; - ticks: int ref; - mutable img: Dom_html.imageElement; - } - -(*setup_sprite is used to initialize a sprite.*) -let setup_sprite ?loop:(loop=true) ?bb_off:(bbox_offset=(0.,0.)) - ?bb_sz:(bbox_size=(0.,0.)) - img_src max_frames max_ticks frame_size src_offset = - let bbox_size = if bbox_size = (0.,0.) then frame_size else bbox_size in - let img_src = "./sprites/" ^ img_src in - { - img_src; - max_frames; - max_ticks; - frame_size; - src_offset; - bbox_offset; - bbox_size; - loop; - } - -(*The following functions are used in order to define sprite animations - *from their sprite sheets. Also creates bounding boxes if necessary.*) - -(*Sets sprite for small mario.*) -let make_small_player (typ, dir) = - match dir with - (* 16x16 grid with 0x0 offset*) - | Left -> begin match typ with - | Standing -> setup_sprite "mario-small.png" ~bb_off:(3.,1.) ~bb_sz:(11.,15.) 1 0 (16.,16.) (0.,0.) - | Jumping -> setup_sprite "mario-small.png" ~bb_off:(2.,1.) ~bb_sz:(13.,15.) 2 10 (16.,16.) (16.,16.) - | Running -> setup_sprite "mario-small.png" ~bb_off:(2.,1.) ~bb_sz:(12.,15.) 3 5 (16.,16.) (16.,0.) - | Crouching -> setup_sprite "mario-small.png" ~bb_off:(1.,5.) ~bb_sz:(14.,10.) 1 0 (16.,16.) (0.,64.) - end - | Right -> begin match typ with - | Standing -> setup_sprite "mario-small.png" ~bb_off:(1.,1.) ~bb_sz:(11.,15.) 1 0 (16.,16.) (0.,32.) - | Jumping -> setup_sprite "mario-small.png" ~bb_off:(2.,1.) ~bb_sz:(13.,15.) 2 10 (16.,16.) (16.,48.) - | Running -> setup_sprite "mario-small.png" ~bb_off:(2.,1.) ~bb_sz:(12.,15.) 3 5 (16.,16.) (16.,32.) - | Crouching -> setup_sprite "mario-small.png" ~bb_off:(1.,5.) ~bb_sz:(14.,10.) 1 0 (16.,16.) (0.,64.) - end - -(*Sets sprite for big mario.*) -let make_big_player (typ, dir) = - match dir with - | Left -> begin match typ with - | Standing -> setup_sprite "mario-big.png" 1 0 ~bb_off:(2.,1.) ~bb_sz:(13.,25.) (16.,27.) (16.,5.) - | Jumping -> setup_sprite "mario-big.png" 1 0 ~bb_off:(2.,1.) ~bb_sz:(12.,25.) (16.,26.) (48.,6.) - | Running -> setup_sprite "mario-big.png" 4 10 ~bb_off:(2.,1.) ~bb_sz:(13.,25.) (16.,27.)(0.,37.) - | Crouching -> setup_sprite "mario-big.png" 1 0 ~bb_off:(2.,10.) ~bb_sz:(13.,17.) (16.,27.) (32.,5.) - end - | Right -> begin match typ with - | Standing -> setup_sprite "mario-big.png" 1 0 ~bb_off:(1.,1.) ~bb_sz:(13.,25.) (16.,26.) (16.,69.) - | Jumping -> setup_sprite "mario-big.png" 1 0 ~bb_off:(2.,1.) ~bb_sz:(12.,25.) (16.,26.) (48.,70.) - | Running -> setup_sprite "mario-big.png" 4 10 ~bb_off:(2.,1.) ~bb_sz:(13.,25.) (16.,27.) (0.,101.) - | Crouching -> setup_sprite "mario-big.png" 1 0 ~bb_off:(2.,10.) ~bb_sz:(13.,17.) (16.,27.) (32.,69.) - end - -(*Sets sprites for enemies: Goomba, Red Koopa, Green Koopa.*) -let make_enemy (typ, dir) = - match (typ, dir) with - | (Goomba,_) -> setup_sprite "enemies.png" ~bb_off:(1.,1.) ~bb_sz:(14.,14.) 2 10 (16.,16.) (0.,128.) - | (GKoopa,Left) -> setup_sprite "enemies.png" ~bb_off:(4.,10.) ~bb_sz:(11.,16.) 2 10 (16.,27.) (0.,69.) - | (GKoopa,Right) -> setup_sprite "enemies.png" ~bb_off:(1.,10.) ~bb_sz:(11.,16.) 2 10 (16.,27.) (32.,69.) - | (RKoopa,Left) -> setup_sprite "enemies.png" ~bb_off:(4.,10.) ~bb_sz:(11.,16.) 2 10 (16.,27.) (0.,5.) - | (RKoopa,Right) -> setup_sprite "enemies.png" ~bb_off:(1.,10.) ~bb_sz:(11.,16.) 2 10 (16.,27.) (32.,5.) - | (GKoopaShell,_) -> setup_sprite "enemies.png" ~bb_off:(2.,2.) ~bb_sz:(12.,13.) 4 10 (16.,16.) (0.,96.) - | (RKoopaShell,_) -> setup_sprite "enemies.png" ~bb_off:(2.,2.) ~bb_sz:(12.,13.) 4 10 (16.,16.) (0.,32.) - -(*Sets sprites for items: coin, fireflower, mushroom, star.*) -let make_item = function - (* 16x16 grid with 0x0 offset *) - | Coin -> setup_sprite "items.png" ~bb_off:(3.,0.) ~bb_sz:(12.,16.) 3 15 (16.,16.) (0.,80.) - | FireFlower -> setup_sprite "items.png" 1 0 (16.,16.) (0.,188.) - | Mushroom -> setup_sprite "items.png" ~bb_off:(2.,0.) ~bb_sz: (12.,16.) 1 0 (16.,16.) (0.,0.) - | Star -> setup_sprite "items.png" 1 0 (16.,16.) (16.,48.) - -(*Sets sprites for blocks: brick, question block, unbreakable block, cloud block -* panel block, ground block.*) -let make_block = function - (* 16x16 grid with 0x0 offset *) - | Brick -> setup_sprite "blocks.png" 5 10 (16.,16.) (0.,0.) - | QBlock _ -> setup_sprite "blocks.png" 4 15 (16.,16.) (0.,16.) - | QBlockUsed -> setup_sprite "blocks.png" 1 0 (16.,16.) (0.,32.) - | UnBBlock -> setup_sprite "blocks.png" 1 0 (16.,16.) (0.,48.) - | Cloud -> setup_sprite "blocks.png" 1 0 (16., 16.) (0., 64.) - | Panel -> setup_sprite "panel.png" 3 15 (26., 26.) (0., 0.) - | Ground -> setup_sprite "ground.png" 1 0 (16., 16.) (0., 32.) - -(*Sets sprites for particles, squished goomba, brick chunks (upon destruction -* of brick), score text.*) -let make_particle = function - | GoombaSquish -> setup_sprite "enemies.png" 1 0 (16.,16.) (0.,144.) - | BrickChunkL -> setup_sprite "chunks.png" 1 0 (8.,8.) (0.,0.) - | BrickChunkR -> setup_sprite "chunks.png" 1 0 (8.,8.) (8.,0.) - | Score100 -> setup_sprite "score.png" 1 0 (12.,8.) (0.,0.) - | Score200 -> setup_sprite "score.png" 1 0 (12.,9.) (0.,9.) - | Score400 -> setup_sprite "score.png" 1 0 (12.,9.) (0.,18.) - | Score800 -> setup_sprite "score.png" 1 0 (12.,9.) (0.,27.) - | Score1000 -> setup_sprite "score.png" 1 0 (14.,9.) (13.,0.) - | Score2000 -> setup_sprite "score.png" 1 0 (14.,9.) (13.,9.) - | Score4000 -> setup_sprite "score.png" 1 0 (14.,9.) (13.,18.) - | Score8000 -> setup_sprite "score.png" 1 0 (14.,9.) (13.,27.) - -(*Calls to set sprite for either big or small mario.*) -let make_player pt spr_type = - match pt with - | BigM -> make_big_player spr_type - | SmallM -> make_small_player spr_type - -(*Calls to set sprites for each type of object.*) -let make_type typ (dir : Actors.dir_1d) = - match typ with - | SPlayer(pt,st) -> make_player pt (st,dir) - | SEnemy t -> make_enemy (t,dir) - | SItem t -> make_item t - | SBlock t -> make_block t - -(* Makes a sprite from provided [params]. *) -let make_from_params params context = - let img = (Dom_html.createImg Dom_html.document) in - (Dom_html.imageElementToJsObj img)##src #= (params.img_src) ; - { - params; - context; - img; - frame = ref 0; - ticks = ref 0; - } - -(*Make is the wrapper function to cycle through sprite animations*) -let make spawn dir context = - let params = make_type spawn dir in - make_from_params params context - -(* Make a background *) -let make_bgd context = - let params = setup_sprite "bgd-1.png" 1 0 (512.,256.) (0.,0.) in - make_from_params params context - -(* Make a particle from the given particle type *) -let make_particle ptyp context = - let params = make_particle ptyp in - make_from_params params context - -(*Transform_enemy is used in order to switch the direction an enemy faces.*) -let transform_enemy enemy_typ spr dir = - let params = make_enemy (enemy_typ,dir) in - let img = (Dom_html.createImg Dom_html.document) in - (Dom_html.imageElementToJsObj img)##src #= (params.img_src) ; - spr.params <- params; - spr.img <- img - -(*update_animation is the main method to cycle through sprite animations*) -let update_animation (spr: sprite) = - (* Only advance frame when ticked *) - let curr_ticks = !(spr.ticks) in - if curr_ticks >= spr.params.max_ticks then begin - spr.ticks := 0; - if spr.params.loop then - spr.frame := (!(spr.frame) + 1) mod spr.params.max_frames - end else spr.ticks := curr_ticks + 1 - -end -module Particle : sig -#1 "particle.mli" -open Actors -open Sprite - -(* Template params associated with a particle *) -type part_params = { - sprite: Sprite.sprite; (* Backing sprite *) - rot: float; (* Rotation *) - lifetime: int; (* Life span *) -} - -type particle = { - params: part_params; - part_type: Actors.part_typ; - pos: Actors.xy; - vel: Actors.xy; - acc: Actors.xy; - mutable kill: bool; (* Kill the particle in the next frame *) - mutable life: int; (* Remaining lifespan of particle *) -} - -(* Makes a new particle of the given particle type with at a position. *) -val make : ?vel:float*float -> ?acc:float*float -> Actors.part_typ - -> float*float -> Dom_html.canvasRenderingContext2D -> particle - -(* Make a score particle. The first int indicates the score to spawn *) -val make_score : int -> float*float -> Dom_html.canvasRenderingContext2D - -> particle - -(* Process a particle, updating its velocity and position. Also marks it as - * killable if it exceeds its lifespan *) -val process : particle -> unit - -end = struct -#1 "particle.ml" -open Actors -open Sprite - -type part_params = { - sprite: Sprite.sprite; - rot: float; - lifetime: int; -} - -type particle = { - params: part_params; - part_type: Actors.part_typ; - pos: Actors.xy; - vel: Actors.xy; - acc: Actors.xy; - mutable kill: bool; - mutable life: int; -} - -(* Converts an x,y [pair] to an Actors.xy record *) -let pair_to_xy pair = { - x = fst pair; - y = snd pair; -} - -(* Function wrapper to assist in generating the template paramss for a - * particle. *) -let make_params sprite rot lifetime = - { - sprite; - rot; - lifetime; - } - -(* Generate the template for a specific particle type *) -let make_type typ ctx = - match typ with - | GoombaSquish as t -> make_params (Sprite.make_particle t ctx) 0. 30 - | BrickChunkL as t -> make_params (Sprite.make_particle t ctx) 0. 300 - | BrickChunkR as t -> make_params (Sprite.make_particle t ctx) 0. 300 - | Score100 as t -> make_params (Sprite.make_particle t ctx) 0. 30 - | Score200 as t -> make_params (Sprite.make_particle t ctx) 0. 30 - | Score400 as t -> make_params (Sprite.make_particle t ctx) 0. 30 - | Score800 as t -> make_params (Sprite.make_particle t ctx) 0. 30 - | Score1000 as t -> make_params (Sprite.make_particle t ctx) 0. 30 - | Score2000 as t -> make_params (Sprite.make_particle t ctx) 0. 30 - | Score4000 as t -> make_params (Sprite.make_particle t ctx) 0. 30 - | Score8000 as t -> make_params (Sprite.make_particle t ctx) 0. 30 - -let make ?vel:(vel=(0.,0.)) ?acc:(acc=(0.,0.)) part_type pos ctx = - let params = make_type part_type ctx in - let pos = pair_to_xy pos and vel = pair_to_xy vel - and acc = pair_to_xy acc in - { - params; - part_type; - pos; - vel; - acc; - kill = false; - life = params.lifetime; - } - -let make_score score pos ctx = - let t = match score with - | 100 -> Score100 - | 200 -> Score200 - | 400 -> Score400 - | 800 -> Score800 - | 1000 -> Score1000 - | 2000 -> Score2000 - | 4000 -> Score4000 - | 8000 -> Score8000 - | _ -> Score100 - in make ~vel:(0.5,-0.7) t pos ctx - -(* Mutably update the velocity of a particle *) -let update_vel part = - part.vel.x <- (part.vel.x +. part.acc.x); - part.vel.y <- (part.vel.y +. part.acc.y) - -(* Mutably update the position of a particle *) -let update_pos part = - part.pos.x <- (part.vel.x +. part.pos.x); - part.pos.y <- (part.vel.y +. part.pos.y) - -let process part = - part.life <- part.life - 1; - if part.life = 0 then (part.kill <- true); - update_vel part; - update_pos part - -end -module Object : sig -#1 "object.mli" -open Sprite -open Actors -open Particle - -val invuln : int (* # of frames of invulnerability *) -val dampen_jump : float (* Boost to jump when enemy jumped on *) - -type aabb = { - center: xy; - half: xy; -} - -type obj_params = { - has_gravity: bool; - speed: float; -} -type obj = { - params: obj_params; - pos: xy; - vel: xy; - id: int; - mutable jumping: bool; - mutable grounded: bool; - mutable dir: Actors.dir_1d; - mutable invuln: int; - mutable kill: bool; - mutable health: int; - mutable crouch: bool; - mutable score: int; -} - -type collidable = - | Player of pl_typ * sprite * obj - | Enemy of enemy_typ * sprite * obj - | Item of item_typ * sprite * obj - | Block of block_typ * sprite * obj - - -(* Returns the sprite associated with the object *) -val get_sprite : collidable -> Sprite.sprite - -val get_obj : collidable -> obj - -(* Creates a new object with a given - * actor type on the the canvas at a given position *) -val spawn : Actors.spawn_typ -> Dom_html.canvasRenderingContext2D - -> float*float -> collidable - -val equals : collidable -> collidable -> bool - -val is_player : collidable -> bool -val is_enemy : collidable -> bool - -val normalize_origin : xy -> Sprite.sprite -> unit - -val normalize_pos : xy -> Sprite.sprite_params -> Sprite.sprite_params -> unit - -(* Destroys the object, returning a list of destruction effect objects *) -val kill : collidable -> Dom_html.canvasRenderingContext2D - -> particle list - -val process_obj : obj -> float -> unit - -val update_player : obj -> Actors.controls list - -> Dom_html.canvasRenderingContext2D - -> (pl_typ * sprite) option - -(* Checks whether a collision occured between two objects, returning the - * direction of the collision if one occurred. *) -val check_collision : collidable -> collidable -> Actors.dir_2d option - -val evolve_enemy : Actors.dir_1d -> Actors.enemy_typ -> Sprite.sprite -> obj - -> Dom_html.canvasRenderingContext2D -> collidable option - -val evolve_block : obj -> Dom_html.canvasRenderingContext2D -> collidable -val dec_health : obj -> unit - -val rev_dir : obj -> Actors.enemy_typ -> Sprite.sprite -> unit - -val reverse_left_right : obj -> unit - -val collide_block : ?check_x: bool -> Actors.dir_2d -> obj -> unit - -val spawn_above : Actors.dir_1d -> obj -> Actors.item_typ - -> Dom_html.canvasRenderingContext2D -> collidable - -end = struct -#1 "object.ml" -open Sprite -open Actors -open Particle - -(*Variables*) -let friction = 0.9 -let gravity = 0.2 -let max_y_vel = 4.5 -let player_speed = 2.8 -let player_jump = 5.7 -let player_max_jump = -6. -let dampen_jump = 4. -let invuln = 60 - -type aabb = { - center: xy; - half: xy; -} - -type obj_params = { - has_gravity: bool; - speed: float; -} - -let id_counter = ref min_int - -type obj = { - params: obj_params; - pos: xy; - vel: xy; - id: int; - mutable jumping: bool; - mutable grounded: bool; - mutable dir: Actors.dir_1d; - mutable invuln: int; - mutable kill: bool; - mutable health: int; - mutable crouch: bool; - mutable score: int; -} - -type collidable = - | Player of pl_typ * sprite * obj - | Enemy of enemy_typ * sprite * obj - | Item of item_typ * sprite * obj - | Block of block_typ * sprite * obj - - -(*setup_obj is used to set gravity and speed, with default values true and 1.*) -let setup_obj ?g:(has_gravity=true) ?spd:(speed=1.) () = - { - has_gravity; - speed; - } - -(* Sets an object's x velocity to the speed specified in its params based on - * its direction *) -let set_vel_to_speed obj = - let speed = obj.params.speed in - match obj.dir with - | Left -> obj.vel.x <- ~-.speed - | Right -> obj.vel.x <- speed - -(* The following make functions all set the objects' has_gravity and speed, - * returning an [obj_params] that can be directly plugged into the [obj] - * during creation. *) -let make_player () = setup_obj ~spd:player_speed () - -let make_item = function - | Mushroom -> setup_obj () - | FireFlower -> setup_obj () - | Star -> setup_obj () - | Coin -> setup_obj ~g:false () - -let make_enemy = function - | Goomba -> setup_obj () - | GKoopa -> setup_obj () - | RKoopa -> setup_obj () - | GKoopaShell -> setup_obj ~spd:3. () - | RKoopaShell -> setup_obj ~spd:3. () - -let make_block = function - | QBlock i -> setup_obj ~g:false () - | QBlockUsed -> setup_obj ~g:false () - | Brick -> setup_obj ~g:false () - | UnBBlock -> setup_obj ~g:false () - | Cloud -> setup_obj ~g: false () - | Panel -> setup_obj ~g: false () - | Ground -> setup_obj ~g: false () - -let make_type = function - | SPlayer(pt,t) -> make_player () (* FIXME: why unused param introduced here *) - | SEnemy t -> make_enemy t - | SItem t -> make_item t - | SBlock t -> make_block t - -(*Used in object creation and to compare two objects.*) -let new_id () = - id_counter := !id_counter + 1; - !id_counter - -(*Used to return a new sprite and object of a created spawnable object*) -let make ?id:(id=None) ?dir:(dir=Left) spawnable context (posx, posy) = - let spr = Sprite.make spawnable dir context in - let params = make_type spawnable in - let id = match id with - | None -> new_id () - | Some n -> n - in - let obj = { - params; - pos = {x=posx; y=posy}; - vel = {x=0.0;y=0.0}; - id; - jumping = false; - grounded = false; - dir; - invuln = 0; - kill = false; - health = 1; - crouch = false; - score = 0; - } in - (spr,obj) - -(*spawn returns a new collidable*) -let spawn spawnable context (posx, posy) = - let (spr,obj) = make spawnable context (posx, posy) in - match spawnable with - | SPlayer(typ,t) -> Player(typ,spr,obj) - | SEnemy t -> - set_vel_to_speed obj; - Enemy(t,spr,obj) - | SItem t -> Item(t,spr,obj) - | SBlock t -> Block(t,spr,obj) - -(*Helper methods for getting sprites and objects from their collidables*) -let get_sprite = function - | Player (_,s,_) | Enemy (_,s, _) | Item (_,s, _) | Block (_,s, _) -> s - -let get_obj = function - | Player (_,_,o) | Enemy (_,_,o) | Item (_,_,o) | Block (_,_,o) -> o - -let is_player = function - | Player(_,_,_) -> true - | _ -> false - -let is_enemy = function - | Enemy(_,_,_) -> true - | _ -> false - -let equals col1 col2 = (get_obj col1).id = (get_obj col2).id - -(*Matches the controls being used and updates each of the player's params.*) -let update_player_keys (player : obj) (controls : controls) : unit = - let lr_acc = player.vel.x *. 0.2 in - match controls with - | CLeft -> - if not player.crouch then begin - if player.vel.x > ~-.(player.params.speed) - then player.vel.x <- player.vel.x -. (0.4 -. lr_acc); - player.dir <- Left - end - | CRight -> - if not player.crouch then begin - if player.vel.x < player.params.speed - then player.vel.x <- player.vel.x +. (0.4 +. lr_acc); - player.dir <- Right - end - | CUp -> - if (not player.jumping && player.grounded) then begin - player.jumping <- true; - player.grounded <- false; - player.vel.y <- - max (player.vel.y -.(player_jump +. abs_float player.vel.x *. 0.25)) - player_max_jump - end - | CDown -> - if (not player.jumping && player.grounded) then - player.crouch <- true - -(*Used for sprite changing. If sprites change to different dimensions as a result - *of some action, the new sprite must be normalized so that things aren't - *jumpy*) -let normalize_pos pos (p1:Sprite.sprite_params) (p2:Sprite.sprite_params) = - let (box1,boy1) = p1.bbox_offset and (box2,boy2) = p2.bbox_offset in - let (bw1,bh1) = p1.bbox_size and (bw2,bh2) = p2.bbox_size in - pos.x <- pos.x -. (bw2 +. box2) +. (bw1 +. box1); - pos.y <- pos.y -. (bh2 +. boy2) +. (bh1 +. boy1) - -(*Update player is constantly being called to check for if big or small - *Mario sprites/collidables should be used.*) -let update_player player keys context = - let prev_jumping = player.jumping in - let prev_dir = player.dir and prev_vx = abs_float player.vel.x in - List.iter (update_player_keys player) keys; - let v = player.vel.x *. friction in - let vel_damped = if abs_float v < 0.1 then 0. else v in - player.vel.x <- vel_damped; - let pl_typ = if player.health <= 1 then SmallM else BigM in - if not prev_jumping && player.jumping - then Some (pl_typ, (Sprite.make (SPlayer(pl_typ,Jumping)) player.dir context)) - else if prev_dir<>player.dir || (prev_vx=0. && (abs_float player.vel.x) > 0.) - && not player.jumping - then Some (pl_typ, (Sprite.make (SPlayer(pl_typ,Running)) player.dir context)) - else if prev_dir <> player.dir && player.jumping && prev_jumping - then Some (pl_typ, (Sprite.make (SPlayer(pl_typ,Jumping)) player.dir context)) - else if player.vel.y = 0. && player.crouch - then Some (pl_typ, (Sprite.make (SPlayer(pl_typ,Crouching)) player.dir context)) - else if player.vel.y = 0. && player.vel.x = 0. - then Some (pl_typ, (Sprite.make (SPlayer(pl_typ,Standing)) player.dir context)) - else None - -(*The following two helper methods update velocity and position of the player*) -let update_vel obj = - if obj.grounded then obj.vel.y <- 0. - else if obj.params.has_gravity then - obj.vel.y <- min (obj.vel.y +. gravity +. abs_float obj.vel.y *. 0.01) max_y_vel - -let update_pos obj = - obj.pos.x <- (obj.vel.x +. obj.pos.x); - if obj.params.has_gravity then obj.pos.y <- (obj.vel.y +. obj.pos.y) - -(*Calls two above helper functions to update velocity and position of player.*) -let process_obj obj mapy = - update_vel obj; - update_pos obj; - if obj.pos.y > mapy then obj.kill <- true - -(* Converts an origin based on the bottom left of the bounding box to the top - * right of the sprite, to make it easier to place objects flush with the ground.*) -let normalize_origin pos (spr:Sprite.sprite) = - let p = spr.params in - let (box,boy) = p.bbox_offset and (_,bh) = p.bbox_size in - pos.x <- pos.x -. box; - pos.y <- pos.y -. (boy +. bh) - -(*Checks upon collision of block and updates the values of the object.*) -let collide_block ?check_x:(check_x=true) dir obj = - match dir with - | North -> obj.vel.y <- -0.001 - | South -> - obj.vel.y <- 0.; - obj.grounded <- true; - obj.jumping <- false; - | East | West -> if check_x then obj.vel.x <- 0. - -(*Simple helper method that reverses the direction in question*) -let opposite_dir dir = - match dir with - | Left -> Right - | Right -> Left - -(*Used for enemy-enemy collisions*) -let reverse_left_right obj = - obj.vel.x <- ~-.(obj.vel.x); - obj.dir <- opposite_dir obj.dir - -(*Actually creates a new enemy and deletes the previous. The positions must be - *normalized. This method is typically called when enemies are killed and a - *new sprite must be used (i.e., koopa to koopa shell). *) -let evolve_enemy player_dir typ (spr:Sprite.sprite) obj context = - match typ with - | GKoopa -> - let (new_spr,new_obj) = - make ~dir:obj.dir (SEnemy GKoopaShell) context (obj.pos.x,obj.pos.y) in - normalize_pos new_obj.pos spr.params new_spr.params; - Some(Enemy(GKoopaShell,new_spr,new_obj)) - | RKoopa -> - let (new_spr,new_obj) = - make ~dir:obj.dir (SEnemy RKoopaShell) context (obj.pos.x,obj.pos.y) in - normalize_pos new_obj.pos spr.params new_spr.params; - Some(Enemy(RKoopaShell,new_spr,new_obj)) - | GKoopaShell |RKoopaShell -> - obj.dir <- player_dir; - if obj.vel.x <> 0. then obj.vel.x <- 0. else set_vel_to_speed obj; - None - | _ -> obj.kill <- true; None - -(*Updates the direction of the sprite. *) -let rev_dir o t (s:sprite) = - reverse_left_right o; - let old_params = s.params in - Sprite.transform_enemy t s o.dir; - normalize_pos o.pos old_params s.params - -(*Used for killing enemies, or to make big Mario into small Mario*) -let dec_health obj = - let health = obj.health - 1 in - if health = 0 then obj.kill <- true else - if obj.invuln = 0 then - obj.health <- health - -(*Used for deleting a block and replacing it with a used block*) -let evolve_block obj context = - dec_health obj; - let (new_spr,new_obj) = - make (SBlock QBlockUsed) context (obj.pos.x, obj.pos.y) in - Block(QBlockUsed,new_spr,new_obj) - -(*Used for making a small Mario into a Big Mario*) -let evolve_player (spr : Sprite.sprite) obj context = - let (new_spr,new_obj) = - make (SPlayer (BigM,Standing)) context (obj.pos.x, obj.pos.y) in - normalize_pos new_obj.pos spr.params new_spr.params ; - Player(BigM,new_spr,new_obj) - -(*Used for spawning items above question mark blocks*) -let spawn_above player_dir obj typ context = - let item = spawn (SItem typ) context (obj.pos.x, obj.pos.y) in - let item_obj = get_obj item in - item_obj.pos.y <- item_obj.pos.y -. (snd (get_sprite item).params.frame_size); - item_obj.dir <- opposite_dir player_dir; - set_vel_to_speed item_obj; - item - -(*Used to get the bounding box.*) -let get_aabb obj = - let spr = ((get_sprite obj).params) in - let obj = get_obj obj in - let (offx, offy) = spr.bbox_offset in - let (box,boy) = (obj.pos.x+.offx,obj.pos.y+.offy) in - let (sx,sy) = spr.bbox_size in - { - center = {x=(box+.sx/.2.);y=(boy+.sy/.2.)}; - half = {x=sx/.2.;y=sy/.2.}; - } - -let col_bypass c1 c2 = - let o1 = get_obj c1 and o2 = get_obj c2 in - let ctypes = match(c1,c2) with - | (Item(_,_,_), Enemy(_,_,_)) - | (Enemy(_,_,_), Item(_,_,_)) - | (Item(_,_,_), Item(_,_,_)) -> true - | (Player(_,_,o1), Enemy(_,_,_)) -> if o1.invuln > 0 then true else false - | _ -> false - in o1.kill || o2.kill || ctypes - -(*Used for checking if collisions occur. Compares half-widths and half-heights - *and adjusts for when collisions do occur, by changing position so that - *a second collision does not occur again immediately. This causes snapping.*) -let check_collision c1 c2 = - let b1 = get_aabb c1 and b2 = get_aabb c2 in - let o1 = get_obj c1 in - if col_bypass c1 c2 then None else - let vx = (b1.center.x) -. (b2.center.x) in - let vy = (b1.center.y) -. (b2.center.y) in - let hwidths = (b1.half.x) +. (b2.half.x) in - let hheights = (b1.half.y) +. (b2.half.y) in - if abs_float vx < hwidths && abs_float vy < hheights then begin - let ox = hwidths -. abs_float vx in - let oy = hheights -. abs_float vy in - if ox >= oy then begin - if vy > 0. then (o1.pos.y <- (o1.pos.y+.oy); Some North) - else (o1.pos.y <- (o1.pos.y -. oy); Some South) - end else begin - if vx > 0. then (o1.pos.x <- o1.pos.x +.ox; Some West) - else (o1.pos.x <- o1.pos.x -. ox; Some East) - end - end else None - -(*"Kills" the matched object by setting certain parameters for each.*) -let kill collid ctx = - match collid with - | Enemy(t,s,o) -> - let pos = (o.pos.x,o.pos.y) in - let score = if o.score > 0 then [Particle.make_score o.score pos ctx] else [] in - let remains = begin match t with - | Goomba -> [Particle.make GoombaSquish pos ctx] - | _ -> [] - end in - score @ remains - | Block(t,s,o) -> - begin match t with - | Brick -> - let pos = (o.pos.x,o.pos.y) in - let p1 = Particle.make ~vel:(-5.,-5.) ~acc:(0.,0.2) BrickChunkL pos ctx in - let p2 = Particle.make ~vel:(-3.,-4.) ~acc:(0.,0.2) BrickChunkL pos ctx in - let p3 = Particle.make ~vel:(3.,-4.) ~acc:(0.,0.2) BrickChunkR pos ctx in - let p4 = Particle.make ~vel:(5.,-5.) ~acc:(0.,0.2) BrickChunkR pos ctx in - [p1;p2;p3;p4] - | _ -> [] - end - | Item(t,s,o) -> - begin match t with - | Mushroom -> [Particle.make_score o.score (o.pos.x,o.pos.y) ctx] - | _ -> [] - end - | _ -> [] - -end -module Draw : sig -#1 "draw.mli" - -(* Renders a given object on the canvas *) -val render : Sprite.sprite -> float * float -> unit - -(* Clears the canvas *) -val clear_canvas : Dom_html.canvasElement -> unit - -(* Draw the given sprite as a background *) -val draw_bgd : Sprite.sprite -> float -> unit - -(* Draws the axis aligned bounding box of the sprite at the position *) -val render_bbox : Sprite.sprite -> float * float -> unit - -(* Draws the fps on the canvas *) -val fps : Dom_html.canvasElement -> float -> unit - -(* Draw the heads up display *) -val hud : Dom_html.canvasElement -> int -> int -> unit - -(* Draw the game win screen *) -val game_win : Dom_html.canvasRenderingContext2D -> unit - -(* Draw the game loss screen *) -val game_loss : Dom_html.canvasRenderingContext2D -> unit - -end = struct -#1 "draw.ml" -open Object -open Sprite -module Html = Dom_html -let document = Html.document - -let get_context canvas = canvas##getContext "2d" - -let render_bbox sprite (posx,posy) = - let context = Dom_html.canvasRenderingContext2DToJsObj sprite.context in - let (bbox,bboy) = sprite.params.bbox_offset in - let (bbsx,bbsy) = sprite.params.bbox_size in - context##strokeStyle #= "#FF0000"; - context##strokeRect (posx+.bbox) (posy+.bboy) bbsx bbsy - -(*Draws a sprite onto the canvas.*) -let render sprite (posx,posy) = - let context = Dom_html.canvasRenderingContext2DToJsObj sprite.context in - let (sx, sy) = sprite.params.src_offset in - let (sw, sh) = sprite.params.frame_size in - let (dx, dy) = (posx,posy) in - let (dw, dh) = sprite.params.frame_size in - let sx = sx +. (float_of_int !(sprite.frame)) *. sw in - (*print_endline (string_of_int !(sprite.frame));*) - (*context##clearRect(0.,0.,sw, sh);*) - context##drawImage sprite.img sx sy sw sh dx dy dw dh - -(*Draws two background images, which needs to be done because of the - *constantly changing viewport, which is always at most going to be - *between two background images.*) -let draw_bgd bgd off_x = - render bgd (~-.off_x,0.); - render bgd ((fst bgd.params.frame_size) -. off_x, 0.) - -(*Used for animation updating. Canvas is cleared each frame and redrawn.*) -let clear_canvas canvas = - let canvas = Dom_html.canvasElementToJsObj canvas in - let context = Dom_html.canvasRenderingContext2DToJsObj (canvas##getContext "2d") in - let cwidth = float_of_int canvas##width in - let cheight = float_of_int canvas##height in - ignore @@ context##clearRect 0. 0. cwidth cheight - -(*Displays the text for score and coins.*) -let hud canvas score coins = - let score_string = string_of_int score in - let coin_string = string_of_int coins in - let canvas = Dom_html.canvasElementToJsObj canvas in - let context = Dom_html.canvasRenderingContext2DToJsObj (canvas##getContext "2d") in - ignore @@ context##font #= ( ("10px 'Press Start 2P'")); - ignore @@ context##fillText ("Score: "^score_string) ((float_of_int canvas##width) -. 140.) 18.; - ignore @@ context##fillText ("Coins: "^coin_string) 120. 18. - -(*Displays the fps.*) -let fps canvas fps_val = - let fps_str = int_of_float fps_val |> string_of_int in - let canvas = Dom_html.canvasElementToJsObj canvas in - let context = Dom_html.canvasRenderingContext2DToJsObj (canvas##getContext "2d") in - ignore @@ context##fillText fps_str 10. 18. - -(*game_win displays a black screen when you finish a game.*) -let game_win ctx = - let ctx = Dom_html.canvasRenderingContext2DToJsObj ctx in - ctx##rect 0. 0. 512. 512.; - ctx##fillStyle #= ( "black"); - ctx##fill (); - ctx##fillStyle #= ( "white"); - ctx##font #= ( "20px 'Press Start 2P'"); - ctx##fillText ("You win!") 180. 128.; - failwith "Game over." - -(*gave_loss displays a black screen stating a loss to finish that level play.*) -let game_loss ctx = - let ctx = Dom_html.canvasRenderingContext2DToJsObj ctx in - ctx##rect 0. 0. 512. 512.; - ctx##fillStyle #= ( "black"); - ctx##fill (); - ctx##fillStyle #= ( "white"); - ctx##font #= ( "20px 'Press Start 2P'"); - ctx##fillText ( "GAME OVER. You lose!") 60. 128.; - failwith "Game over." - -let draw_background_color canvas = failwith "todo" - - -end -module Viewport : sig -#1 "viewport.mli" -open Actors - -type viewport = { - pos: Actors.xy; (* Absolute position of viewport relative to map *) - v_dim: Actors.xy; (* Dimensions of viewport *) - m_dim: Actors.xy; (* Dimensions of map *) -} - -(* Makes a new viewport of viewport dimensions and map dimensions*) -val make : float*float -> float*float -> viewport - -(* Calculates the viewport origin point *) -val calc_viewport_point : float -> float -> float -> float - -(* Whether the supplied position is outside of the viewport *) -val in_viewport : viewport -> Actors.xy -> bool - -(* Whether the supplied position is below the viewport *) -val out_of_viewport_below : viewport -> float -> bool - -(* Converts absolute coordinates to viewport coodinates *) -val coord_to_viewport : viewport -> Actors.xy -> Actors.xy - -(* Update the viewport *) -val update : viewport -> Actors.xy -> viewport - -end = struct -#1 "viewport.ml" -open Actors - -type viewport = { - pos: Actors.xy; - v_dim: Actors.xy; - m_dim: Actors.xy; -} - -let make (vx,vy) (mx,my) = - { - pos = {x = 0.; y = 0.;}; - v_dim = {x = vx; y = vy}; - m_dim = {x = mx; y = my}; - } - -(* Calculates the viewport origin coordinate given the centering coordinate - * [cc], the canvas coordinate [vc], and the map coordinate [mc]. This function - * works for both x and y. At the extreme points, it will ensure that the - * viewport is always within bounds of the map, even if it is no longer - * centered about the origin point. *) -let calc_viewport_point cc vc mc = - let vc_half = vc /. 2. in - min ( max (cc -. vc_half) 0. ) ( min (mc -. vc) (abs_float(cc -. vc_half)) ) - -(* Returns whether a coordinate pair [pos] is inside the viewport [v] *) -let in_viewport v pos = - let margin = 32. in - let (v_min_x,v_max_x) = (v.pos.x -. margin, v.pos.x +. v.v_dim.x) in - let (v_min_y,v_max_y) = (v.pos.y -. margin, v.pos.y +. v.v_dim.y) in - let (x,y) = (pos.x, pos.y) in - x >= v_min_x && x <= v_max_x && y >= v_min_y && y<= v_max_y - -(* Returns whether an object is outside of the viewport and below it. This is - * useful for determining whether to process falling out of screen normally. *) -let out_of_viewport_below v y = - let v_max_y = v.pos.y +. v.v_dim.y in - y >= v_max_y - -(* Converts a x,y [coord] pair in absolute coordinates to coordinates relative - * to the viewport *) -let coord_to_viewport viewport coord = - { - x = coord.x -. viewport.pos.x; - y = coord.y -. viewport.pos.y; - } - -(* Update the viewport [vpt] given the new center x,y coordinate pair [ctr] *) -let update vpt ctr = - let new_x = calc_viewport_point ctr.x vpt.v_dim.x vpt.m_dim.x in - let new_y = calc_viewport_point ctr.y vpt.v_dim.y vpt.m_dim.y in - let pos = {x = new_x; y = new_y} in - {vpt with pos} - - -end -module Director : sig -#1 "director.mli" -(* Initiates the main game loop *) -val update_loop : Dom_html.canvasElement - -> (Object.collidable * Object.collidable list) - -> float*float - -> unit - -(* Keydown event handler function *) -val keydown : Dom.keyboardEvent -> bool - -(* Keyup event handler function *) -val keyup : Dom.keyboardEvent -> bool - -end = struct -#1 "director.ml" -open Sprite -open Object -open Actors -open Viewport -open Particle - -(* Represents the values of relevant key bindings. *) -type keys = { - mutable left: bool; - mutable right: bool; - mutable up: bool; - mutable down: bool; - mutable bbox: int; -} - - -(*st represents the state of the game. It includes a background sprite (e.g., - * (e.g., hills), a context (used for rendering onto the page), a viewport - * (used for moving the player's "camera"), a score (which is kept track - * throughout the game), coins (also kept track through the game), - * a multiplier (used for when you kill multiple enemies before ever touching - * the ground, as in the actual Super Mario), and a game_over bool (which - * is only true when the game is over). *) -type st = { - bgd: sprite; - ctx: Dom_html.canvasRenderingContext2D; - vpt: viewport; - map: float; - mutable score: int; - mutable coins: int; - mutable multiplier: int; - mutable game_over: bool; -} - -(*pressed_keys instantiates the keys.*) -let pressed_keys = { - left = false; - right = false; - up = false; - down = false; - bbox = 0; -} - -let collid_objs = ref [] (* List of next iteration collidable objects *) -let particles = ref [] (* List of next iteration particles *) -let last_time = ref 0. (* Used for calculating fps *) - - -(* Calculates fps as the difference between [t0] and [t1] *) -let calc_fps t0 t1 = - let delta = (t1 -. t0) /. 1000. in - 1. /. delta - -(* Adds [i] to the score in [state] *) -let update_score state i = - state.score <- state.score + i - -(*player_attack_enemy is called for a player hitting an enemy from the north. - *This causes the player to either kill the enemy or move the enemy, in the - *case that the enemy is a shell. Invulnerability, jumping, and grounded - *are used for fine tuning the movements.*) -let player_attack_enemy s1 o1 typ s2 o2 state context = - o1.invuln <- 10; - o1.jumping <- false; - o1.grounded <- true; - begin match typ with - | GKoopaShell | RKoopaShell -> - let r2 = evolve_enemy o1.dir typ s2 o2 context in - o1.vel.y <- ~-. dampen_jump; - o1.pos.y <- o1.pos.y -. 5.; - (None,r2) - | _ -> - dec_health o2; - o1.vel.y <- ~-. dampen_jump; - if state.multiplier = 8 then begin - update_score state 800; - o2.score <- 800; - (None, evolve_enemy o1.dir typ s2 o2 context) - end else begin - let score = 100 * state.multiplier in - update_score state score; - o2.score <- score; - state.multiplier <- state.multiplier * 2; - (None,(evolve_enemy o1.dir typ s2 o2 context)) - end - end - -(*enemy_attack_player is used when an enemy kills a player.*) -let enemy_attack_player s1 (o1:Object.obj) t2 s2 (o2:Object.obj) context = - begin match t2 with - | GKoopaShell |RKoopaShell -> - let r2 = if o2.vel.x = 0. then evolve_enemy o1.dir t2 s2 o2 context - else (dec_health o1; o1.invuln <- invuln; None) in - (None,r2) - | _ -> dec_health o1; o1.invuln <- invuln; (None,None) - end - -(*In the case that two enemies collide, they are to reverse directions. However, - *in the case that one or more of the two enemies is a koopa shell, then - *the koopa shell kills the other enemy. *) -let col_enemy_enemy t1 s1 o1 t2 s2 o2 dir = - begin match (t1, t2) with - | (GKoopaShell, GKoopaShell) - | (GKoopaShell, RKoopaShell) - | (RKoopaShell, RKoopaShell) - | (RKoopaShell, GKoopaShell) -> - dec_health o1; - dec_health o2; - (None,None) - | (RKoopaShell, _) | (GKoopaShell, _) -> if o1.vel.x = 0. then - (rev_dir o2 t2 s2; - (None,None) ) - else ( dec_health o2; (None,None) ) - | (_, RKoopaShell) | (_, GKoopaShell) -> if o2.vel.x = 0. then - (rev_dir o1 t1 s1; - (None,None) ) - else ( dec_health o1; (None,None) ) - | (_, _) -> - begin match dir with - | West | East -> - rev_dir o1 t1 s1; - rev_dir o2 t2 s2; - (None,None) - | _ -> (None,None) - end - end - -(* Gets the object at a given position *) -let obj_at_pos dir (pos: xy) (collids: Object.collidable list) - : Object.collidable list = - match dir with - | Left -> List.filter (fun (col: Object.collidable) -> - (get_obj col).pos.y = pos.y && (get_obj col).pos.x = pos.x -. 16.) - collids - | _ -> List.filter (fun (col: Object.collidable) -> - (get_obj col).pos.y = pos.y && (get_obj col).pos.x = pos.x +. 16.) - collids - -(* Returns whether the object at a given position is a block *) -let is_block dir pos collids = - match obj_at_pos dir pos collids with - | [] -> false - | [Block (_,_,_)] -> true - | _ -> false - -(* Returns whether the given object is a red koopa *) -let is_rkoopa collid = - match collid with - | Enemy(RKoopa,_,_) -> true - | _ -> false - -(* Process collision is called to match each of the possible collisions that - * may occur. Returns a pair of collidable options, representing objects that - * were created from the existing ones. That is, the first element represents - * a new item spawned as a result of the first collidable. None indicates that - * no new item should be spawned. Transformations to existing objects occur - * mutably, as many changes are side-effectual.*) -let process_collision (dir : Actors.dir_2d) (c1 : Object.collidable) - (c2 : Object.collidable) (state : st) : (Object.collidable option * Object.collidable option) = - let context = state.ctx in - match (c1, c2, dir) with - | (Player(_,s1,o1), Enemy(typ,s2,o2), South) - | (Enemy(typ,s2,o2),Player(_,s1,o1), North) -> - player_attack_enemy s1 o1 typ s2 o2 state context - | (Player(_,s1,o1), Enemy(t2,s2,o2), _) - | (Enemy(t2,s2,o2), Player(_,s1,o1), _) -> - enemy_attack_player s1 o1 t2 s2 o2 context - | (Player(_,s1,o1), Item(t2,s2,o2), _) - | (Item(t2,s2,o2), Player(_,s1,o1), _) -> - begin match t2 with - | Mushroom -> - dec_health o2; - (if o1.health = 2 then () else o1.health <- o1.health + 1); - o1.vel.x <- 0.; - o1.vel.y <- 0.; - update_score state 1000; - o2.score <- 1000; - (None, None) - | Coin -> state.coins <- state.coins + 1; dec_health o2; - update_score state 100; - (None, None) - | _ -> dec_health o2; update_score state 1000; (None, None) - end - | (Enemy(t1,s1,o1), Enemy(t2,s2,o2), dir) -> - col_enemy_enemy t1 s1 o1 t2 s2 o2 dir - | (Enemy(t1,s1,o1), Block(t2,s2,o2), East) - | (Enemy(t1,s1,o1), Block(t2,s2,o2), West)-> - begin match (t1,t2) with (* FIXME *) - | (RKoopaShell, Brick) | (GKoopaShell, Brick) -> - dec_health o2; - reverse_left_right o1; - (None,None) - | (RKoopaShell, QBlock typ) | (GKoopaShell, QBlock typ) -> - let updated_block = evolve_block o2 context in - let spawned_item = spawn_above o1.dir o2 typ context in - rev_dir o1 t1 s1; - (Some updated_block, Some spawned_item) - | (_,_) -> - rev_dir o1 t1 s1; - (None,None) - end - | (Item(_,s1,o1), Block(typ2,s2,o2), East) - | (Item(_,s1,o1), Block(typ2,s2,o2), West) -> - reverse_left_right o1; - (None, None) - | (Enemy(_,s1,o1), Block(typ2,s2,o2), _) - | (Item(_,s1,o1), Block(typ2,s2,o2), _) -> - collide_block dir o1; - (None, None) - | (Player(t1,s1,o1), Block(t,s2,o2), North) -> - begin match t with - | QBlock typ -> - let updated_block = evolve_block o2 context in - let spawned_item = spawn_above o1.dir o2 typ context in - collide_block dir o1; - (Some spawned_item, Some updated_block) - | Brick -> if t1 = BigM then begin - collide_block dir o1; dec_health o2; (None, None) end - else (collide_block dir o1; (None,None)) - | Panel -> Draw.game_win state.ctx; (None,None) - | _ -> collide_block dir o1; (None,None) - end - | (Player(_,s1,o1), Block(t,s2,o2), _) -> - begin match t with - | Panel -> Draw.game_win state.ctx; (None,None) - | _ -> - begin match dir with - | South -> state.multiplier <- 1 ; collide_block dir o1; (None, None) - | _ -> collide_block dir o1; (None, None) - end - end - | (_, _, _) -> (None,None) - -(* Run the broad phase object filtering *) -let broad_phase collid all_collids state = - let obj = get_obj collid in - List.filter (fun c -> - in_viewport state.vpt obj.pos || is_player collid || - out_of_viewport_below state.vpt obj.pos.y) all_collids - -(*narrow_phase of collision is used in order to continuously loop through - *each of the collidable objects to constantly check if collisions are - *occurring.*) -let rec narrow_phase c cs state = - let rec narrow_helper c cs state acc = - match cs with - | [] -> acc - | h::t -> - let c_obj = get_obj c in - let new_objs = if not (equals c h) then - begin match Object.check_collision c h with - | None -> (None,None) - | Some dir -> - if (get_obj h).id <> c_obj.id - then begin - (*( (if (if is_rkoopa c then - begin match c_obj.dir with - | Left -> is_block c_obj.dir {x= c_obj.pos.x -. 16.; y= c_obj.pos.y -. 27.} cs - | _ -> is_block c_obj.dir {x= c_obj.pos.x +. 16.; y= c_obj.pos.y -. 27.} cs - end else false) then rev_dir c_obj RKoopa (Object.get_sprite c) else - ());*) - process_collision dir c h state - end - else (None,None) - end else (None,None) in - let acc = match new_objs with - | (None, Some o) -> o::acc - | (Some o, None) -> o::acc - | (Some o1, Some o2) -> o1::o2::acc - | (None, None) -> acc - in - narrow_helper c t state acc - in narrow_helper c cs state [] - -(* This is an optimization setp to determine which objects require narrow phase - * checking. This excludes static collidables, allowing collision to only be - * checked with moving objects. This method is called once per collidable. - * Collision detection proceeds as follows: - * 1. Broad phase - filter collidables that cannot possibly collide with - * this object. - * 2. Narrow phase - compare against all objects to determine whether there - * is a collision, and process the collision. - * This method returns a list of objects that are created, which should be - * added to the list of collidables for the next iteration. - * *) -let check_collisions collid all_collids state = - match collid with - | Block(_,_,_) -> [] - | _ -> - let broad = broad_phase collid all_collids state in - narrow_phase collid broad state - -(* Returns whether the bounding box should be drawn *) -let check_bbox_enabled () = pressed_keys.bbox = 1 - -(* update_collidable is the primary update method for collidable objects, - * checking the collision, updating the object, and drawing to the canvas.*) -let update_collidable state (collid:Object.collidable) all_collids = - (* TODO: optimize. Draw static elements only once *) - let obj = Object.get_obj collid in - let spr = Object.get_sprite collid in - obj.invuln <- if obj.invuln > 0 then obj.invuln - 1 else 0; - (* Prevent position from being updated outside of viewport *) - let viewport_filter = in_viewport state.vpt obj.pos || is_player collid || - out_of_viewport_below state.vpt obj.pos.y in - if not obj.kill && viewport_filter then begin - obj.grounded <- false; - Object.process_obj obj state.map; - (* Run collision detection if moving object*) - let evolved = check_collisions collid all_collids state in - (* Render and update animation *) - let vpt_adj_xy = coord_to_viewport state.vpt obj.pos in - Draw.render spr (vpt_adj_xy.x,vpt_adj_xy.y); - if check_bbox_enabled() - then Draw.render_bbox spr (vpt_adj_xy.x,vpt_adj_xy.y); - - if obj.vel.x <> 0. || not (is_enemy collid) - then Sprite.update_animation spr; - evolved - end else [] - -(* Converts a keypress to a list of control keys, allowing more than one key - * to be processed each frame. *) -let translate_keys () = - let k = pressed_keys in - let ctrls = [(k.left,CLeft);(k.right,CRight);(k.up,CUp);(k.down,CDown)] in - List.fold_left (fun a x -> if fst x then (snd x)::a else a) [] ctrls - -(* run_update is used to update all of the collidables at once. Primarily used - * as a wrapper method. This method is necessary to differentiate between - * the player collidable and the remaining collidables, as special operations - * such as viewport centering only occur with the player.*) -let run_update_collid state collid all_collids = - match collid with - | Player(t,s,o) as p -> - let keys = translate_keys () in - o.crouch <- false; - let player = begin match Object.update_player o keys state.ctx with - | None -> p - | Some (new_typ, new_spr) -> - Object.normalize_pos o.pos s.params new_spr.params; - Player(new_typ,new_spr,o) - end in - let evolved = update_collidable state player all_collids in - collid_objs := !collid_objs @ evolved; - player - | _ -> - let obj = get_obj collid in - let evolved = update_collidable state collid all_collids in - if not obj.kill then (collid_objs := collid::(!collid_objs@evolved)); - let new_parts = if obj.kill then Object.kill collid state.ctx else [] in - particles := !particles @ new_parts; - collid - -(* Primary update function to update and persist a particle *) -let run_update_particle state part = - Particle.process part; - let x=part.pos.x -. state.vpt.pos.x and y=part.pos.y -. state.vpt.pos.y in - Draw.render part.params.sprite (x,y); - if not part.kill then particles := part :: !particles - -(*update_loop is constantly being called to check for collisions and to - *update each of the objects in the game.*) -let update_loop canvas (player,objs) map_dim = - let scale = 1. in - let ctx = (Dom_html.canvasElementToJsObj canvas)##getContext "2d" in - let cwidth = (float_of_int (Dom_html.canvasElementToJsObj canvas)##width) /. scale in - let cheight = (float_of_int (Dom_html.canvasElementToJsObj canvas)##height) /. scale in - let viewport = Viewport.make (cwidth,cheight) map_dim in - let state = { - bgd = Sprite.make_bgd ctx; - vpt = Viewport.update viewport (get_obj player).pos; - ctx; - score = 0; - coins = 0; - multiplier = 1; - map = snd map_dim; - game_over = false; - } in - (Dom_html.canvasRenderingContext2DToJsObj state.ctx)##scale scale scale; - let rec update_helper time state player objs parts = - if state.game_over = true then Draw.game_win state.ctx else begin - collid_objs := []; - particles := []; - - let fps = calc_fps !last_time time in - last_time := time; - - Draw.clear_canvas canvas; - - (* Parallax background *) - let vpos_x_int = int_of_float (state.vpt.pos.x /. 5.) in - let bgd_width = int_of_float (fst state.bgd.params.frame_size) in - Draw.draw_bgd state.bgd (float_of_int (vpos_x_int mod bgd_width)); - - let player = run_update_collid state player objs in - - if (get_obj player).kill = true - then Draw.game_loss state.ctx else begin - let state = { - state with vpt = Viewport.update state.vpt (get_obj player).pos} in - List.iter (fun obj -> ignore (run_update_collid state obj objs)) objs; - List.iter (fun part -> run_update_particle state part) parts; - Draw.fps canvas fps; - Draw.hud canvas state.score state.coins; - ignore @@ Dom_html.requestAnimationFrame( - fun (t:float) -> - update_helper t state player !collid_objs !particles) - end - end - in update_helper 0. state player objs [] - -(* Keydown event handler translates a key press *) -let keydown evt = - let evt = Dom_html.keyboardEventToJsObj evt in - let () = match evt##keyCode with - | 38 | 32 | 87 -> pressed_keys.up <- true - | 39 | 68 -> pressed_keys.right <- true - | 37 | 65 -> pressed_keys.left <- true - | 40 | 83 -> pressed_keys.down <- true - | 66 -> pressed_keys.bbox <- (pressed_keys.bbox + 1) mod 2 - | _ -> () - in true - -(* Keyup event handler translates a key release *) -let keyup evt = - let evt = Dom_html.keyboardEventToJsObj evt in - let () = match evt##keyCode with - | 38 | 32 | 87 -> pressed_keys.up <- false - | 39 | 68 -> pressed_keys.right <- false - | 37 | 65 -> pressed_keys.left <- false - | 40 | 83 -> pressed_keys.down <- false - | _ -> () - in true - -end -module Procedural_generator : sig -#1 "procedural_generator.mli" -open Object -open Actors - -type obj_coord - -val init : unit -> unit - -(* Procedurally generates a new map of default size*) -val generate : float -> float -> Dom_html.canvasRenderingContext2D -> - collidable * collidable list - -end = struct -#1 "procedural_generator.ml" -open Actors -open Object - -(*Note: Canvas is 512 by 256 (w*h) -> 32 by 16 blocks*) - -(*Holds obj typ and its coordinates. (int, (x-coord, y-coord))*) -type obj_coord = int * (float * float) - -(*Checks if the given location checkloc is already part of the list of locations -* in loclist.*) -let rec mem_loc (checkloc: float * float) (loclist: obj_coord list) : bool = - match loclist with - |[] -> false - |h::t -> if (checkloc = (snd h)) then true - else mem_loc checkloc t - -(*Converts list of locations from blocksize to pixelsize by multiplying (x,y) by -* 16.*) -let rec convert_list (lst:obj_coord list) :obj_coord list = - match lst with - |[] -> [] - |(h::t) -> [(fst h, ((fst (snd h))*.16.,(snd (snd h))*.16.))]@(convert_list t) - -(*Chooses what type of enemy should be instantiated given typ number*) -let choose_enemy_typ (typ:int) : enemy_typ = - match typ with - |0 -> RKoopa - |1 -> GKoopa - |2 -> Goomba - |_ -> failwith "Shouldn't reach here" - -(*Chooses what type of block should be instantiated given typ number*) -let choose_sblock_typ (typ:int) : block_typ = - match typ with - |0 -> Brick - |1 -> UnBBlock - |2 -> Cloud - |3 -> QBlock Mushroom - |4 -> Ground - |_ -> failwith "Shouldn't reach here" - -(*Optimizes lst such that there are no two items in the list that have the same -* coordinates. If there is one, it is removed.*) -let rec avoid_overlap (lst:obj_coord list) (currentLst:obj_coord list) - : obj_coord list = - match lst with - |[] -> [] - |h::t -> if(mem_loc (snd h) currentLst) then avoid_overlap t currentLst - else [h]@(avoid_overlap t currentLst) - -(*Gets rid of objects with coordinates in the ending frame, within 128 pixels of -* the start, at the very top, and two blocks from the ground.*) -let rec trim_edges (lst: obj_coord list) (blockw:float) (blockh: float) - : obj_coord list = - match lst with - |[] -> [] - |h::t -> let cx = fst(snd h) in - let cy = snd(snd h) in - let pixx = blockw*.16. in - let pixy = blockh*.16. in - if(cx<128. || pixx-.cx<528. || cy = 0. || pixy-.cy<48.) - then trim_edges t blockw blockh - else [h]@trim_edges t blockw blockh - -(*Generates a stair formation with block typ being dependent on typ. This type -* of stair formation requires that the first step be on the ground.*) -let generate_ground_stairs cbx cby typ = - let four = [(typ, (cbx, cby));(typ, (cbx+.1., cby));(typ, (cbx+.2., cby)); - (typ, (cbx+.3., cby))] in - let three = [(typ,(cbx +. 1., cby -. 1.));(typ,(cbx +. 2., cby -. 1.)); - (typ,(cbx +. 3., cby -. 1.))] in - let two = [(typ,(cbx +. 2., cby -. 2.));(typ,(cbx +. 3., cby -. 2.))] in - let one = [(typ,(cbx +. 3., cby -. 3.))] in - four@three@two@one - -(*Generates a stair formation going upwards.*) -let generate_airup_stairs cbx cby typ = - let one = [(typ,(cbx, cby));(typ,(cbx +. 1., cby))] in - let two = [(typ,(cbx +. 3., cby -. 1.));(typ,(cbx +. 4., cby -. 1.))] in - let three = [(typ,(cbx +. 4., cby -. 2.));(typ,(cbx +. 5., cby -. 2.)); - (typ,(cbx +. 6., cby -. 2.))] in - one@two@three - -(*Generates a stair formation going downwards*) -let generate_airdown_stairs cbx cby typ = - let three = [(typ,(cbx, cby));(typ,(cbx +. 1., cby));(typ,(cbx +. 2., cby))]in - let two = [(typ,(cbx +. 2., cby +. 1.));(typ,(cbx +. 3., cby +. 1.))] in - let one = [(typ,(cbx +. 5., cby +. 2.));(typ,(cbx +. 6., cby +. 2.))] in - three@two@one - -(*Generates a cloud block platform with some length num.*) -let rec generate_clouds cbx cby typ num = - if(num = 0) then [] - else [(typ,(cbx, cby))]@generate_clouds (cbx+.1.) cby typ (num-1) - -(*Generates an obj_coord list (typ, coordinates) of coins to be placed.*) -let rec generate_coins (block_coord: obj_coord list) : obj_coord list = - let place_coin = Random.int 2 in - match block_coord with - |[] -> [] - |h::t -> if(place_coin = 0) then - let xc = fst(snd h) in - let yc = snd(snd h) in - [(0,(xc,(yc-.16.)))]@generate_coins t - else generate_coins t - -(*Chooses the form of the blocks to be placed. -* When called, leaves a 1 block gap from canvas size. -* 1. If current xblock or yblock is greater than canvas width or height -* respectively, return an empty list. -* 2. If current xblock or yblock is within 10 blocks of the left and right sides -* of the level map, prevent any objects from being initialized. -* 3. Else call helper methods to created block formations and return obj_coord -* list. -**) -let choose_block_pattern (blockw:float) (blockh: float) (cbx:float) (cby:float) - (prob:int) : obj_coord list= - if(cbx > blockw || cby > blockh) then [] - else - let block_typ = Random.int 4 in - let stair_typ = Random.int 2 in - let life_block_chance = Random.int 5 in - let middle_block = if(life_block_chance = 0) then 3 else stair_typ in - let obj_coord = - match prob with - |0 -> if(blockw -. cbx > 2.) then [(stair_typ, (cbx, cby)); - (middle_block,(cbx +. 1., cby));(stair_typ,(cbx +. 2., cby))] - else if (blockw -. cbx > 1.) then [(block_typ,(cbx, cby)); - (block_typ,(cbx +. 1., cby))] - else [(block_typ,(cbx, cby))] - |1 -> let num_clouds = (Random.int 5) + 5 in - if(cby < 5.) then generate_clouds cbx cby 2 num_clouds - else [] - |2 -> if(blockh-.cby = 1.) then generate_ground_stairs cbx cby stair_typ - else [] - |3 -> if(stair_typ = 0 && blockh -. cby > 3.) then - generate_airdown_stairs cbx cby stair_typ - else if (blockh-.cby>2.) then generate_airup_stairs cbx cby stair_typ - else [(stair_typ,(cbx, cby))] - |4 -> if ((cby +. 3.) -. blockh = 2.) then [(stair_typ,(cbx, cby))] - else if ((cby +. 3.) -. blockh = 1.) then [(stair_typ, (cbx,cby)); - (stair_typ, (cbx, cby +. 1.))] - else [(stair_typ,(cbx, cby)); (stair_typ,(cbx, cby +. 1.)); - (stair_typ,(cbx, cby +. 2.))] - |5 -> [(3,(cbx, cby))] - |_ -> failwith "Shouldn't reach here" in - obj_coord - -(*Generates a list of enemies to be placed on the ground.*) -let rec generate_enemies (blockw: float) (blockh: float) (cbx: float) - (cby: float) (acc: obj_coord list) = - if(cbx > (blockw-.32.)) then [] - else if (cby > (blockh-. 1.) || cbx < 15.) then - generate_enemies blockw blockh (cbx +. 1.) 0. acc - else if(mem_loc (cbx, cby) acc || cby = 0.) then - generate_enemies blockw blockh cbx (cby+.1.) acc - else - let prob = Random.int 30 in - let enem_prob = 3 in - if(prob < enem_prob && (blockh -. 1. = cby)) then - let enemy = [(prob,(cbx*.16.,cby*.16.))] in - enemy@(generate_enemies blockw blockh cbx (cby+.1.) acc) - else generate_enemies blockw blockh cbx (cby+.1.) acc - -(*Generates a list of enemies to be placed upon the block objects.*) -let rec generate_block_enemies (block_coord: obj_coord list) : obj_coord list = - let place_enemy = Random.int 20 in - let enemy_typ = Random.int 3 in - match block_coord with - |[] -> [] - |h::t -> if(place_enemy = 0) then - let xc = fst(snd h) in - let yc = snd(snd h) in - [(enemy_typ,(xc,(yc-.16.)))]@generate_block_enemies t - else generate_block_enemies t - -(*Generates an obj_coord list (typ, coordinates) of blocks to be placed.*) -let rec generate_block_locs (blockw: float) (blockh: float) (cbx: float) - (cby: float) (acc: obj_coord list) : obj_coord list = - if(blockw-.cbx<33.) then acc - else if (cby > (blockh-. 1.)) then - generate_block_locs blockw blockh (cbx+.1.) 0. acc - else if(mem_loc (cbx, cby) acc || cby = 0.) then - generate_block_locs blockw blockh cbx (cby+.1.) acc - else - let prob = Random.int 100 in - let block_prob = 5 in - if(prob < block_prob) then - let newacc = choose_block_pattern blockw blockh cbx cby prob in - let undup_lst = avoid_overlap newacc acc in - let called_acc = acc@undup_lst in - generate_block_locs blockw blockh cbx (cby+.1.) called_acc - else generate_block_locs blockw blockh cbx (cby+.1.) acc - -(*Generates the ending item panel at the end of the level. Games ends upon -* collision with player.*) -let generate_panel (context:Dom_html.canvasRenderingContext2D) - (blockw: float) (blockh: float) : collidable = - let ob = Object.spawn (SBlock Panel) context - ((blockw*.16.)-.256., (blockh *. 16.)*.2./.3.) in - ob - -(*Generates the list of brick locations needed to display the ground. -* 1/10 chance that a ground block is skipped each call to create holes.*) -let rec generate_ground (blockw:float) (blockh:float) (inc:float) - (acc: obj_coord list) : obj_coord list = - if(inc > blockw) then acc - else - if(inc > 10.) then - let skip = Random.int 10 in - let newacc = acc@[(4, (inc*. 16.,blockh *. 16.))] in - if (skip = 7 && blockw-.inc>32.) - then generate_ground blockw blockh (inc +. 1.) acc - else generate_ground blockw blockh (inc +. 1.) newacc - else let newacc = acc@[(4, (inc*. 16.,blockh *. 16.))] in - generate_ground blockw blockh (inc +. 1.) newacc - -(*Converts the obj_coord list called by generate_block_locs to a list of objects -* with the coordinates given from the obj_coord list. *) -let rec convert_to_block_obj (lst:obj_coord list) - (context:Dom_html.canvasRenderingContext2D) : collidable list = - match lst with - |[] -> [] - |h::t -> - let sblock_typ = choose_sblock_typ (fst h) in - let ob = Object.spawn (SBlock sblock_typ) context (snd h) in - [ob]@(convert_to_block_obj t context) - -(*Converts the obj_coord list called by generate_enemies to a list of objects -* with the coordinates given from the obj_coord list. *) -let rec convert_to_enemy_obj (lst:obj_coord list) - (context:Dom_html.canvasRenderingContext2D) : collidable list = - match lst with - |[] -> [] - |h::t -> - let senemy_typ = choose_enemy_typ (fst h) in - let ob = Object.spawn (SEnemy senemy_typ) context (snd h) in - [ob]@(convert_to_enemy_obj t context) - -(*Converts the list of coordinates into a list of Coin objects*) -let rec convert_to_coin_obj (lst:obj_coord list) - (context:Dom_html.canvasRenderingContext2D) : collidable list = - match lst with - |[] -> [] - |h::t -> - let sitem_typ = Coin in - let ob = Object.spawn (SItem sitem_typ) context (snd h) in - [ob]@(convert_to_coin_obj t context) - -(*Procedurally generates a list of collidables given canvas width, height and -* context. Arguments block width (blockw) and block height (blockh) are in -* block form, not pixels.*) -let generate_helper (blockw:float) (blockh:float) (cx:float) (cy:float) - (context:Dom_html.canvasRenderingContext2D) : collidable list = - let block_locs = generate_block_locs blockw blockh 0. 0. [] in - let converted_block_locs = trim_edges (convert_list block_locs) - blockw blockh in - let obj_converted_block_locs = convert_to_block_obj converted_block_locs - context in - let ground_blocks = generate_ground blockw blockh 0. [] in - let obj_converted_ground_blocks = convert_to_block_obj ground_blocks - context in - let block_locations = block_locs@ground_blocks in - let all_blocks = obj_converted_block_locs@obj_converted_ground_blocks in - let enemy_locs = generate_enemies blockw blockh 0. 0. block_locations in - let obj_converted_enemies = convert_to_enemy_obj enemy_locs context in - let coin_locs = generate_coins converted_block_locs in - let undup_coin_locs = trim_edges(avoid_overlap coin_locs converted_block_locs) - blockw blockh in - let converted_block_coin_locs = converted_block_locs@coin_locs in - let enemy_block_locs = generate_block_enemies converted_block_locs in - let undup_enemy_block_locs = avoid_overlap enemy_block_locs - converted_block_coin_locs in - let obj_enemy_blocks = convert_to_enemy_obj undup_enemy_block_locs context in - let coin_objects = convert_to_coin_obj undup_coin_locs context in - let obj_panel = generate_panel context blockw blockh in - all_blocks@obj_converted_enemies@coin_objects@obj_enemy_blocks@[obj_panel] - -(*Main function called to procedurally generate the level map. w and h args -* are in pixel form. Converts to block form to call generate_helper. Spawns -* the list of collidables received from generate_helper to display on canvas.*) -let generate (w:float) (h:float) - (context:Dom_html.canvasRenderingContext2D) : - (collidable * collidable list) = - let blockw = w/.16. in - let blockh = (h/.16.) -. 1. in - let collide_list = generate_helper blockw blockh 0. 0. context in - let player = Object.spawn (SPlayer(SmallM,Standing)) context (100.,224.) in - (player, collide_list) - -(*Makes sure level map is uniquely generated at each call.*) -let init () = - Random.self_init(); - -end -module Main -= struct -#1 "main.ml" -open Actors -open Sprite -open Object -module Html = Dom_html -module Pg = Procedural_generator - -let loadCount = ref 0 -let imgsToLoad = 4 -let level_width = 2400. -let level_height = 256. - -(*Canvas is chosen from the index.html file. The context is obtained from - *the canvas. Listeners are added. A level is generated and the general - *update_loop method is called to make the level playable.*) -let load _ = - Random.self_init(); - let canvas_id = "canvas" in - let canvas = match Dom_html.getElementById Dom_html.document canvas_id with - | None -> - Js.log {j|cant find canvas $(canvas_id) |j} ; - failwith "fail" - | Some el -> Dom_html.elementToCanvasElement el - in - let context = (Dom_html.canvasElementToJsObj canvas)##getContext "2d" in - let _ = Dom_html.addEventListener Dom_html.document "keydown" (Director.keydown) true in - let _ = Dom_html.addEventListener Dom_html.document "keyup" (Director.keyup) true in - let () = Pg.init () in - let _ = Director.update_loop canvas (Pg.generate level_width level_height context) (level_width,level_height) in - print_endline "asd"; - () - -let inc_counter _ = - loadCount := !loadCount + 1; - if !loadCount = imgsToLoad then load() else () - -(*Used for concurrency issues.*) -let preload _ = - let root_dir = "sprites/" in - let imgs = [ "blocks.png";"items.png";"enemies.png";"mario-small.png" ] in - List.map (fun img_src -> - let img_src = root_dir ^ img_src in - let img = (Html.createImg Dom_html.document) in - (Dom_html.imageElementToJsObj img)##src #= (img_src) ; - ignore(Dom_html.addEventListenerImg img "load" - ( (fun ev -> inc_counter(); true)) true)) imgs - - -let _ = (Dom_html.windowToJsObj Dom_html.window)##onload #= (fun _ -> ignore (preload()); true) - -end diff --git a/jscomp/test/mario_game.res b/jscomp/test/mario_game.res new file mode 100644 index 0000000000..6a89eec364 --- /dev/null +++ b/jscomp/test/mario_game.res @@ -0,0 +1,2642 @@ +@@bs.config({flags: ["-w", "a", "-bs-no-bin-annot"]}) + +module Actors: { + type dir_1d = Left | Right + type dir_2d = North | South | East | West + + /* Generic xy record for easy position access */ + type xy = { + mutable x: float, + mutable y: float, + } + + /* Controls correspond to keyboard input */ + type controls = + | CLeft + | CRight + | CUp + | CDown + + /* Player ability type */ + type pl_typ = + | BigM + | SmallM + + type item_typ = + | Mushroom + | FireFlower + | Star + | Coin + + type enemy_typ = + | Goomba + | GKoopa + | RKoopa + | GKoopaShell + | RKoopaShell + + type block_typ = + | QBlock(item_typ) + | QBlockUsed + | Brick + | UnBBlock + | Cloud + | Panel + | Ground + + /* Player action type */ + type player_typ = + | Standing + | Jumping + | Running + | Crouching + + /* Particle Type */ + type part_typ = + | GoombaSquish + | BrickChunkL + | BrickChunkR + | Score100 + | Score200 + | Score400 + | Score800 + | Score1000 + | Score2000 + | Score4000 + | Score8000 + + /* type unbblock_typ = + | Wood + | Earth + | Brick +| */ + + type spawn_typ = + | SPlayer(pl_typ, player_typ) + | SEnemy(enemy_typ) + | SItem(item_typ) + | SBlock(block_typ) + /* | SGround of ground_typ */ +} = { + type dir_1d = Left | Right + type dir_2d = North | South | East | West + + type xy = { + mutable x: float, + mutable y: float, + } + + type controls = + | CLeft + | CRight + | CUp + | CDown + + type pl_typ = + | BigM + | SmallM + + type item_typ = + | Mushroom + | FireFlower + | Star + | Coin + + type enemy_typ = + | Goomba + | GKoopa + | RKoopa + | GKoopaShell + | RKoopaShell + + type block_typ = + | QBlock(item_typ) + | QBlockUsed + | Brick + | UnBBlock + | Cloud + | Panel + | Ground + + type player_typ = + | Standing + | Jumping + | Running + | Crouching + + type part_typ = + | GoombaSquish + | BrickChunkL + | BrickChunkR + | Score100 + | Score200 + | Score400 + | Score800 + | Score1000 + | Score2000 + | Score4000 + | Score8000 + + type spawn_typ = + | SPlayer(pl_typ, player_typ) + | SEnemy(enemy_typ) + | SItem(item_typ) + | SBlock(block_typ) +} +module Dom_html = { + type imageElement + type canvasRenderingContext2D + type canvasElement + + @val external document: Dom.document = "document" + @val external window: Dom.window = "window" + + /* external createImg: (_ [@bs.as "img"]) -> document -> imageElement = "createElement" [@@bs.send] */ + @send external createImg: (Dom.document, @as("img") _) => imageElement = "createElement" + @val external requestAnimationFrame: (float => unit) => unit = "requestAnimationFrame" + @return(null_to_opt) @send + external getElementById: (Dom.document, string) => option = "getElementById" + @send + external addEventListener: (Dom.document, string, Dom.event_like<'a> => bool, bool) => unit = + "addEventListener" + @send + external addEventListenerImg: (imageElement, string, Dom.event_like<'a> => bool, bool) => unit = + "addEventListener" + + /* unsafe casts */ + external imageElementToJsObj: imageElement => {..} = "%identity" + external canvasRenderingContext2DToJsObj: canvasRenderingContext2D => {..} = "%identity" + external canvasElementToJsObj: canvasElement => {..} = "%identity" + external keyboardEventToJsObj: Dom.keyboardEvent => {..} = "%identity" + external elementToCanvasElement: Dom.element => canvasElement = "%identity" + external windowToJsObj: Dom.window => {..} = "%identity" +} +module Sprite: { + open Actors + + /* Represents an xy vector */ + type xy = (float, float) /* x, y */ + + /* Inherent sprite parameters from which to create the sprite */ + type sprite_params = { + max_frames: int, + max_ticks: int, + img_src: string, + frame_size: xy, + src_offset: xy, + bbox_offset: xy, + bbox_size: xy, + loop: bool, + } + + /* Concrete sprite created to visually represent an object */ + type sprite = { + mutable params: sprite_params, + context: Dom_html.canvasRenderingContext2D, + frame: ref, + ticks: ref, + mutable img: Dom_html.imageElement, + } + + /* Sets up a sprite to create */ + let setup_sprite: ( + ~loop: bool=?, + ~bb_off: (float, float)=?, + ~bb_sz: (float, float)=?, + string, + int, + int, + xy, + xy, + ) => sprite_params + + /* Creates a sprite given the actor type */ + let make: (Actors.spawn_typ, Actors.dir_1d, Dom_html.canvasRenderingContext2D) => sprite + + /* Make a background */ + let make_bgd: Dom_html.canvasRenderingContext2D => sprite + + /* Make a particle corresponding to the given type */ + let make_particle: (Actors.part_typ, Dom_html.canvasRenderingContext2D) => sprite + + /* Transform an enemy sprite based on direction */ + let transform_enemy: (Actors.enemy_typ, sprite, Actors.dir_1d) => unit + + /* Updates the sprite's animation */ + let update_animation: sprite => unit +} = { + open Actors + + type xy = (float, float) + + type sprite_params = { + max_frames: int, + max_ticks: int, + img_src: string, + frame_size: xy, + src_offset: xy, + bbox_offset: xy, + bbox_size: xy, + loop: bool, + } + + type sprite = { + mutable params: sprite_params, + context: Dom_html.canvasRenderingContext2D, + frame: ref, + ticks: ref, + mutable img: Dom_html.imageElement, + } + + /* setup_sprite is used to initialize a sprite. */ + let setup_sprite = ( + ~loop=true, + ~bb_off as bbox_offset=(0., 0.), + ~bb_sz as bbox_size=(0., 0.), + img_src, + max_frames, + max_ticks, + frame_size, + src_offset, + ) => { + let bbox_size = if bbox_size == (0., 0.) { + frame_size + } else { + bbox_size + } + let img_src = "./sprites/" ++ img_src + { + img_src, + max_frames, + max_ticks, + frame_size, + src_offset, + bbox_offset, + bbox_size, + loop, + } + } + + /* The following functions are used in order to define sprite animations + *from their sprite sheets. Also creates bounding boxes if necessary. */ + + /* Sets sprite for small mario. */ + let make_small_player = ((typ, dir)) => + switch dir { + /* 16x16 grid with 0x0 offset */ + | Left => + switch typ { + | Standing => + setup_sprite( + "mario-small.png", + ~bb_off=(3., 1.), + ~bb_sz=(11., 15.), + 1, + 0, + (16., 16.), + (0., 0.), + ) + | Jumping => + setup_sprite( + "mario-small.png", + ~bb_off=(2., 1.), + ~bb_sz=(13., 15.), + 2, + 10, + (16., 16.), + (16., 16.), + ) + | Running => + setup_sprite( + "mario-small.png", + ~bb_off=(2., 1.), + ~bb_sz=(12., 15.), + 3, + 5, + (16., 16.), + (16., 0.), + ) + | Crouching => + setup_sprite( + "mario-small.png", + ~bb_off=(1., 5.), + ~bb_sz=(14., 10.), + 1, + 0, + (16., 16.), + (0., 64.), + ) + } + | Right => + switch typ { + | Standing => + setup_sprite( + "mario-small.png", + ~bb_off=(1., 1.), + ~bb_sz=(11., 15.), + 1, + 0, + (16., 16.), + (0., 32.), + ) + | Jumping => + setup_sprite( + "mario-small.png", + ~bb_off=(2., 1.), + ~bb_sz=(13., 15.), + 2, + 10, + (16., 16.), + (16., 48.), + ) + | Running => + setup_sprite( + "mario-small.png", + ~bb_off=(2., 1.), + ~bb_sz=(12., 15.), + 3, + 5, + (16., 16.), + (16., 32.), + ) + | Crouching => + setup_sprite( + "mario-small.png", + ~bb_off=(1., 5.), + ~bb_sz=(14., 10.), + 1, + 0, + (16., 16.), + (0., 64.), + ) + } + } + + /* Sets sprite for big mario. */ + let make_big_player = ((typ, dir)) => + switch dir { + | Left => + switch typ { + | Standing => + setup_sprite( + "mario-big.png", + 1, + 0, + ~bb_off=(2., 1.), + ~bb_sz=(13., 25.), + (16., 27.), + (16., 5.), + ) + | Jumping => + setup_sprite( + "mario-big.png", + 1, + 0, + ~bb_off=(2., 1.), + ~bb_sz=(12., 25.), + (16., 26.), + (48., 6.), + ) + | Running => + setup_sprite( + "mario-big.png", + 4, + 10, + ~bb_off=(2., 1.), + ~bb_sz=(13., 25.), + (16., 27.), + (0., 37.), + ) + | Crouching => + setup_sprite( + "mario-big.png", + 1, + 0, + ~bb_off=(2., 10.), + ~bb_sz=(13., 17.), + (16., 27.), + (32., 5.), + ) + } + | Right => + switch typ { + | Standing => + setup_sprite( + "mario-big.png", + 1, + 0, + ~bb_off=(1., 1.), + ~bb_sz=(13., 25.), + (16., 26.), + (16., 69.), + ) + | Jumping => + setup_sprite( + "mario-big.png", + 1, + 0, + ~bb_off=(2., 1.), + ~bb_sz=(12., 25.), + (16., 26.), + (48., 70.), + ) + | Running => + setup_sprite( + "mario-big.png", + 4, + 10, + ~bb_off=(2., 1.), + ~bb_sz=(13., 25.), + (16., 27.), + (0., 101.), + ) + | Crouching => + setup_sprite( + "mario-big.png", + 1, + 0, + ~bb_off=(2., 10.), + ~bb_sz=(13., 17.), + (16., 27.), + (32., 69.), + ) + } + } + + /* Sets sprites for enemies: Goomba, Red Koopa, Green Koopa. */ + let make_enemy = ((typ, dir)) => + switch (typ, dir) { + | (Goomba, _) => + setup_sprite( + "enemies.png", + ~bb_off=(1., 1.), + ~bb_sz=(14., 14.), + 2, + 10, + (16., 16.), + (0., 128.), + ) + | (GKoopa, Left) => + setup_sprite( + "enemies.png", + ~bb_off=(4., 10.), + ~bb_sz=(11., 16.), + 2, + 10, + (16., 27.), + (0., 69.), + ) + | (GKoopa, Right) => + setup_sprite( + "enemies.png", + ~bb_off=(1., 10.), + ~bb_sz=(11., 16.), + 2, + 10, + (16., 27.), + (32., 69.), + ) + | (RKoopa, Left) => + setup_sprite("enemies.png", ~bb_off=(4., 10.), ~bb_sz=(11., 16.), 2, 10, (16., 27.), (0., 5.)) + | (RKoopa, Right) => + setup_sprite( + "enemies.png", + ~bb_off=(1., 10.), + ~bb_sz=(11., 16.), + 2, + 10, + (16., 27.), + (32., 5.), + ) + | (GKoopaShell, _) => + setup_sprite("enemies.png", ~bb_off=(2., 2.), ~bb_sz=(12., 13.), 4, 10, (16., 16.), (0., 96.)) + | (RKoopaShell, _) => + setup_sprite("enemies.png", ~bb_off=(2., 2.), ~bb_sz=(12., 13.), 4, 10, (16., 16.), (0., 32.)) + } + + /* Sets sprites for items: coin, fireflower, mushroom, star. */ + let make_item = x => + /* 16x16 grid with 0x0 offset */ + switch x { + | Coin => + setup_sprite("items.png", ~bb_off=(3., 0.), ~bb_sz=(12., 16.), 3, 15, (16., 16.), (0., 80.)) + | FireFlower => setup_sprite("items.png", 1, 0, (16., 16.), (0., 188.)) + | Mushroom => + setup_sprite("items.png", ~bb_off=(2., 0.), ~bb_sz=(12., 16.), 1, 0, (16., 16.), (0., 0.)) + | Star => setup_sprite("items.png", 1, 0, (16., 16.), (16., 48.)) + } + + /* Sets sprites for blocks: brick, question block, unbreakable block, cloud block + * panel block, ground block. */ + let make_block = x => + /* 16x16 grid with 0x0 offset */ + switch x { + | Brick => setup_sprite("blocks.png", 5, 10, (16., 16.), (0., 0.)) + | QBlock(_) => setup_sprite("blocks.png", 4, 15, (16., 16.), (0., 16.)) + | QBlockUsed => setup_sprite("blocks.png", 1, 0, (16., 16.), (0., 32.)) + | UnBBlock => setup_sprite("blocks.png", 1, 0, (16., 16.), (0., 48.)) + | Cloud => setup_sprite("blocks.png", 1, 0, (16., 16.), (0., 64.)) + | Panel => setup_sprite("panel.png", 3, 15, (26., 26.), (0., 0.)) + | Ground => setup_sprite("ground.png", 1, 0, (16., 16.), (0., 32.)) + } + + /* Sets sprites for particles, squished goomba, brick chunks (upon destruction + * of brick), score text. */ + let make_particle = x => + switch x { + | GoombaSquish => setup_sprite("enemies.png", 1, 0, (16., 16.), (0., 144.)) + | BrickChunkL => setup_sprite("chunks.png", 1, 0, (8., 8.), (0., 0.)) + | BrickChunkR => setup_sprite("chunks.png", 1, 0, (8., 8.), (8., 0.)) + | Score100 => setup_sprite("score.png", 1, 0, (12., 8.), (0., 0.)) + | Score200 => setup_sprite("score.png", 1, 0, (12., 9.), (0., 9.)) + | Score400 => setup_sprite("score.png", 1, 0, (12., 9.), (0., 18.)) + | Score800 => setup_sprite("score.png", 1, 0, (12., 9.), (0., 27.)) + | Score1000 => setup_sprite("score.png", 1, 0, (14., 9.), (13., 0.)) + | Score2000 => setup_sprite("score.png", 1, 0, (14., 9.), (13., 9.)) + | Score4000 => setup_sprite("score.png", 1, 0, (14., 9.), (13., 18.)) + | Score8000 => setup_sprite("score.png", 1, 0, (14., 9.), (13., 27.)) + } + + /* Calls to set sprite for either big or small mario. */ + let make_player = (pt, spr_type) => + switch pt { + | BigM => make_big_player(spr_type) + | SmallM => make_small_player(spr_type) + } + + /* Calls to set sprites for each type of object. */ + let make_type = (typ, dir: Actors.dir_1d) => + switch typ { + | SPlayer(pt, st) => make_player(pt, (st, dir)) + | SEnemy(t) => make_enemy((t, dir)) + | SItem(t) => make_item(t) + | SBlock(t) => make_block(t) + } + + /* Makes a sprite from provided [params]. */ + let make_from_params = (params, context) => { + let img = Dom_html.createImg(Dom_html.document) + Dom_html.imageElementToJsObj(img)["src"] = params.img_src + { + params, + context, + img, + frame: ref(0), + ticks: ref(0), + } + } + + /* Make is the wrapper function to cycle through sprite animations */ + let make = (spawn, dir, context) => { + let params = make_type(spawn, dir) + make_from_params(params, context) + } + + /* Make a background */ + let make_bgd = context => { + let params = setup_sprite("bgd-1.png", 1, 0, (512., 256.), (0., 0.)) + make_from_params(params, context) + } + + /* Make a particle from the given particle type */ + let make_particle = (ptyp, context) => { + let params = make_particle(ptyp) + make_from_params(params, context) + } + + /* Transform_enemy is used in order to switch the direction an enemy faces. */ + let transform_enemy = (enemy_typ, spr, dir) => { + let params = make_enemy((enemy_typ, dir)) + let img = Dom_html.createImg(Dom_html.document) + Dom_html.imageElementToJsObj(img)["src"] = params.img_src + spr.params = params + spr.img = img + } + + /* update_animation is the main method to cycle through sprite animations */ + let update_animation = (spr: sprite) => { + /* Only advance frame when ticked */ + let curr_ticks = spr.ticks.contents + if curr_ticks >= spr.params.max_ticks { + spr.ticks := 0 + if spr.params.loop { + spr.frame := mod(spr.frame.contents + 1, spr.params.max_frames) + } + } else { + spr.ticks := curr_ticks + 1 + } + } +} +module Particle: { + open Actors + open Sprite + + type part_params = { + sprite: Sprite.sprite, + rot: float, + lifetime: int, + } + + type particle = { + params: part_params, + part_type: Actors.part_typ, + pos: Actors.xy, + vel: Actors.xy, + acc: Actors.xy, + mutable kill: bool, + mutable life: int, + } + + let make: ( + ~vel: (float, float)=?, + ~acc: (float, float)=?, + Actors.part_typ, + (float, float), + Dom_html.canvasRenderingContext2D, + ) => particle + + let make_score: (int, (float, float), Dom_html.canvasRenderingContext2D) => particle + + let process: particle => unit +} = /* Template params associated with a particle */ + +/* Backing sprite */ +/* Rotation */ +/* Life span */ + +/* Kill the particle in the next frame */ +/* Remaining lifespan of particle */ + +/* Makes a new particle of the given particle type with at a position. */ + +/* Make a score particle. The first int indicates the score to spawn */ + +/* Process a particle, updating its velocity and position. Also marks it as + * killable if it exceeds its lifespan */ + +{ + open Actors + open Sprite + + type part_params = { + sprite: Sprite.sprite, + rot: float, + lifetime: int, + } + + type particle = { + params: part_params, + part_type: Actors.part_typ, + pos: Actors.xy, + vel: Actors.xy, + acc: Actors.xy, + mutable kill: bool, + mutable life: int, + } + + /* Converts an x,y [pair] to an Actors.xy record */ + let pair_to_xy = pair => { + x: fst(pair), + y: snd(pair), + } + + /* Function wrapper to assist in generating the template paramss for a + * particle. */ + let make_params = (sprite, rot, lifetime) => { + sprite, + rot, + lifetime, + } + + /* Generate the template for a specific particle type */ + let make_type = (typ, ctx) => + switch typ { + | GoombaSquish as t => make_params(Sprite.make_particle(t, ctx), 0., 30) + | BrickChunkL as t => make_params(Sprite.make_particle(t, ctx), 0., 300) + | BrickChunkR as t => make_params(Sprite.make_particle(t, ctx), 0., 300) + | Score100 as t => make_params(Sprite.make_particle(t, ctx), 0., 30) + | Score200 as t => make_params(Sprite.make_particle(t, ctx), 0., 30) + | Score400 as t => make_params(Sprite.make_particle(t, ctx), 0., 30) + | Score800 as t => make_params(Sprite.make_particle(t, ctx), 0., 30) + | Score1000 as t => make_params(Sprite.make_particle(t, ctx), 0., 30) + | Score2000 as t => make_params(Sprite.make_particle(t, ctx), 0., 30) + | Score4000 as t => make_params(Sprite.make_particle(t, ctx), 0., 30) + | Score8000 as t => make_params(Sprite.make_particle(t, ctx), 0., 30) + } + + let make = (~vel=(0., 0.), ~acc=(0., 0.), part_type, pos, ctx) => { + let params = make_type(part_type, ctx) + let pos = pair_to_xy(pos) + and vel = pair_to_xy(vel) + and acc = pair_to_xy(acc) + { + params, + part_type, + pos, + vel, + acc, + kill: false, + life: params.lifetime, + } + } + + let make_score = (score, pos, ctx) => { + let t = switch score { + | 100 => Score100 + | 200 => Score200 + | 400 => Score400 + | 800 => Score800 + | 1000 => Score1000 + | 2000 => Score2000 + | 4000 => Score4000 + | 8000 => Score8000 + | _ => Score100 + } + make(~vel=(0.5, -0.7), t, pos, ctx) + } + + /* Mutably update the velocity of a particle */ + let update_vel = part => { + part.vel.x = part.vel.x +. part.acc.x + part.vel.y = part.vel.y +. part.acc.y + } + + /* Mutably update the position of a particle */ + let update_pos = part => { + part.pos.x = part.vel.x +. part.pos.x + part.pos.y = part.vel.y +. part.pos.y + } + + let process = part => { + part.life = part.life - 1 + if part.life == 0 { + part.kill = true + } + update_vel(part) + update_pos(part) + } +} +module Object: { + open Sprite + open Actors + open Particle + + let invuln: int + let dampen_jump: float + + type aabb = { + center: xy, + half: xy, + } + + type obj_params = { + has_gravity: bool, + speed: float, + } + type obj = { + params: obj_params, + pos: xy, + vel: xy, + id: int, + mutable jumping: bool, + mutable grounded: bool, + mutable dir: Actors.dir_1d, + mutable invuln: int, + mutable kill: bool, + mutable health: int, + mutable crouch: bool, + mutable score: int, + } + + type collidable = + | Player(pl_typ, sprite, obj) + | Enemy(enemy_typ, sprite, obj) + | Item(item_typ, sprite, obj) + | Block(block_typ, sprite, obj) + + let get_sprite: collidable => Sprite.sprite + + let get_obj: collidable => obj + + let spawn: (Actors.spawn_typ, Dom_html.canvasRenderingContext2D, (float, float)) => collidable + + let equals: (collidable, collidable) => bool + + let is_player: collidable => bool + let is_enemy: collidable => bool + + let normalize_origin: (xy, Sprite.sprite) => unit + + let normalize_pos: (xy, Sprite.sprite_params, Sprite.sprite_params) => unit + + let kill: (collidable, Dom_html.canvasRenderingContext2D) => list + + let process_obj: (obj, float) => unit + + let update_player: ( + obj, + list, + Dom_html.canvasRenderingContext2D, + ) => option<(pl_typ, sprite)> + + let check_collision: (collidable, collidable) => option + + let evolve_enemy: ( + Actors.dir_1d, + Actors.enemy_typ, + Sprite.sprite, + obj, + Dom_html.canvasRenderingContext2D, + ) => option + + let evolve_block: (obj, Dom_html.canvasRenderingContext2D) => collidable + let dec_health: obj => unit + + let rev_dir: (obj, Actors.enemy_typ, Sprite.sprite) => unit + + let reverse_left_right: obj => unit + + let collide_block: (~check_x: bool=?, Actors.dir_2d, obj) => unit + + let spawn_above: ( + Actors.dir_1d, + obj, + Actors.item_typ, + Dom_html.canvasRenderingContext2D, + ) => collidable +} = /* # of frames of invulnerability */ +/* Boost to jump when enemy jumped on */ + +/* Returns the sprite associated with the object */ + +/* Creates a new object with a given + * actor type on the the canvas at a given position */ + +/* Destroys the object, returning a list of destruction effect objects */ + +/* Checks whether a collision occured between two objects, returning the + * direction of the collision if one occurred. */ + +{ + open Sprite + open Actors + open Particle + + /* Variables */ + let friction = 0.9 + let gravity = 0.2 + let max_y_vel = 4.5 + let player_speed = 2.8 + let player_jump = 5.7 + let player_max_jump = -6. + let dampen_jump = 4. + let invuln = 60 + + type aabb = { + center: xy, + half: xy, + } + + type obj_params = { + has_gravity: bool, + speed: float, + } + + let id_counter = ref(min_int) + + type obj = { + params: obj_params, + pos: xy, + vel: xy, + id: int, + mutable jumping: bool, + mutable grounded: bool, + mutable dir: Actors.dir_1d, + mutable invuln: int, + mutable kill: bool, + mutable health: int, + mutable crouch: bool, + mutable score: int, + } + + type collidable = + | Player(pl_typ, sprite, obj) + | Enemy(enemy_typ, sprite, obj) + | Item(item_typ, sprite, obj) + | Block(block_typ, sprite, obj) + + /* setup_obj is used to set gravity and speed, with default values true and 1. */ + let setup_obj = (~g as has_gravity=true, ~spd as speed=1., ()) => { + has_gravity, + speed, + } + + /* Sets an object's x velocity to the speed specified in its params based on + * its direction */ + let set_vel_to_speed = obj => { + let speed = obj.params.speed + switch obj.dir { + | Left => obj.vel.x = -.speed + | Right => obj.vel.x = speed + } + } + + /* The following make functions all set the objects' has_gravity and speed, + * returning an [obj_params] that can be directly plugged into the [obj] + * during creation. */ + let make_player = () => setup_obj(~spd=player_speed, ()) + + let make_item = x => + switch x { + | Mushroom => setup_obj() + | FireFlower => setup_obj() + | Star => setup_obj() + | Coin => setup_obj(~g=false, ()) + } + + let make_enemy = x => + switch x { + | Goomba => setup_obj() + | GKoopa => setup_obj() + | RKoopa => setup_obj() + | GKoopaShell => setup_obj(~spd=3., ()) + | RKoopaShell => setup_obj(~spd=3., ()) + } + + let make_block = x => + switch x { + | QBlock(i) => setup_obj(~g=false, ()) + | QBlockUsed => setup_obj(~g=false, ()) + | Brick => setup_obj(~g=false, ()) + | UnBBlock => setup_obj(~g=false, ()) + | Cloud => setup_obj(~g=false, ()) + | Panel => setup_obj(~g=false, ()) + | Ground => setup_obj(~g=false, ()) + } + + let make_type = x => + switch x { + | SPlayer(pt, t) => make_player() /* FIXME: why unused param introduced here */ + | SEnemy(t) => make_enemy(t) + | SItem(t) => make_item(t) + | SBlock(t) => make_block(t) + } + + /* Used in object creation and to compare two objects. */ + let new_id = () => { + id_counter := id_counter.contents + 1 + id_counter.contents + } + + /* Used to return a new sprite and object of a created spawnable object */ + let make = (~id=None, ~dir=Left, spawnable, context, (posx, posy)) => { + let spr = Sprite.make(spawnable, dir, context) + let params = make_type(spawnable) + let id = switch id { + | None => new_id() + | Some(n) => n + } + + let obj = { + params, + pos: {x: posx, y: posy}, + vel: {x: 0.0, y: 0.0}, + id, + jumping: false, + grounded: false, + dir, + invuln: 0, + kill: false, + health: 1, + crouch: false, + score: 0, + } + (spr, obj) + } + + /* spawn returns a new collidable */ + let spawn = (spawnable, context, (posx, posy)) => { + let (spr, obj) = make(spawnable, context, (posx, posy)) + switch spawnable { + | SPlayer(typ, t) => Player(typ, spr, obj) + | SEnemy(t) => + set_vel_to_speed(obj) + Enemy(t, spr, obj) + | SItem(t) => Item(t, spr, obj) + | SBlock(t) => Block(t, spr, obj) + } + } + + /* Helper methods for getting sprites and objects from their collidables */ + let get_sprite = x => + switch x { + | Player(_, s, _) | Enemy(_, s, _) | Item(_, s, _) | Block(_, s, _) => s + } + + let get_obj = x => + switch x { + | Player(_, _, o) | Enemy(_, _, o) | Item(_, _, o) | Block(_, _, o) => o + } + + let is_player = x => + switch x { + | Player(_, _, _) => true + | _ => false + } + + let is_enemy = x => + switch x { + | Enemy(_, _, _) => true + | _ => false + } + + let equals = (col1, col2) => get_obj(col1).id == get_obj(col2).id + + /* Matches the controls being used and updates each of the player's params. */ + let update_player_keys = (player: obj, controls: controls): unit => { + let lr_acc = player.vel.x *. 0.2 + switch controls { + | CLeft => + if !player.crouch { + if player.vel.x > -.player.params.speed { + player.vel.x = player.vel.x -. (0.4 -. lr_acc) + } + player.dir = Left + } + | CRight => + if !player.crouch { + if player.vel.x < player.params.speed { + player.vel.x = player.vel.x +. (0.4 +. lr_acc) + } + player.dir = Right + } + | CUp => + if !player.jumping && player.grounded { + player.jumping = true + player.grounded = false + player.vel.y = max( + player.vel.y -. (player_jump +. abs_float(player.vel.x) *. 0.25), + player_max_jump, + ) + } + | CDown => + if !player.jumping && player.grounded { + player.crouch = true + } + } + } + + /* Used for sprite changing. If sprites change to different dimensions as a result + *of some action, the new sprite must be normalized so that things aren't + *jumpy */ + let normalize_pos = (pos, p1: Sprite.sprite_params, p2: Sprite.sprite_params) => { + let (box1, boy1) = p1.bbox_offset and (box2, boy2) = p2.bbox_offset + let (bw1, bh1) = p1.bbox_size and (bw2, bh2) = p2.bbox_size + pos.x = pos.x -. (bw2 +. box2) +. (bw1 +. box1) + pos.y = pos.y -. (bh2 +. boy2) +. (bh1 +. boy1) + } + + /* Update player is constantly being called to check for if big or small + *Mario sprites/collidables should be used. */ + let update_player = (player, keys, context) => { + let prev_jumping = player.jumping + let prev_dir = player.dir and prev_vx = abs_float(player.vel.x) + List.iter(update_player_keys(player), keys) + let v = player.vel.x *. friction + let vel_damped = if abs_float(v) < 0.1 { + 0. + } else { + v + } + player.vel.x = vel_damped + let pl_typ = if player.health <= 1 { + SmallM + } else { + BigM + } + if !prev_jumping && player.jumping { + Some(pl_typ, Sprite.make(SPlayer(pl_typ, Jumping), player.dir, context)) + } else if ( + prev_dir != player.dir || (prev_vx == 0. && abs_float(player.vel.x) > 0. && !player.jumping) + ) { + Some(pl_typ, Sprite.make(SPlayer(pl_typ, Running), player.dir, context)) + } else if prev_dir != player.dir && (player.jumping && prev_jumping) { + Some(pl_typ, Sprite.make(SPlayer(pl_typ, Jumping), player.dir, context)) + } else if player.vel.y == 0. && player.crouch { + Some(pl_typ, Sprite.make(SPlayer(pl_typ, Crouching), player.dir, context)) + } else if player.vel.y == 0. && player.vel.x == 0. { + Some(pl_typ, Sprite.make(SPlayer(pl_typ, Standing), player.dir, context)) + } else { + None + } + } + + /* The following two helper methods update velocity and position of the player */ + let update_vel = obj => + if obj.grounded { + obj.vel.y = 0. + } else if obj.params.has_gravity { + obj.vel.y = min(obj.vel.y +. gravity +. abs_float(obj.vel.y) *. 0.01, max_y_vel) + } + + let update_pos = obj => { + obj.pos.x = obj.vel.x +. obj.pos.x + if obj.params.has_gravity { + obj.pos.y = obj.vel.y +. obj.pos.y + } + } + + /* Calls two above helper functions to update velocity and position of player. */ + let process_obj = (obj, mapy) => { + update_vel(obj) + update_pos(obj) + if obj.pos.y > mapy { + obj.kill = true + } + } + + /* Converts an origin based on the bottom left of the bounding box to the top + * right of the sprite, to make it easier to place objects flush with the ground. */ + let normalize_origin = (pos, spr: Sprite.sprite) => { + let p = spr.params + let (box, boy) = p.bbox_offset and (_, bh) = p.bbox_size + pos.x = pos.x -. box + pos.y = pos.y -. (boy +. bh) + } + + /* Checks upon collision of block and updates the values of the object. */ + let collide_block = (~check_x=true, dir, obj) => + switch dir { + | North => obj.vel.y = -0.001 + | South => + obj.vel.y = 0. + obj.grounded = true + obj.jumping = false + | East | West => + if check_x { + obj.vel.x = 0. + } + } + + /* Simple helper method that reverses the direction in question */ + let opposite_dir = dir => + switch dir { + | Left => Right + | Right => Left + } + + /* Used for enemy-enemy collisions */ + let reverse_left_right = obj => { + obj.vel.x = -.obj.vel.x + obj.dir = opposite_dir(obj.dir) + } + + /* Actually creates a new enemy and deletes the previous. The positions must be + *normalized. This method is typically called when enemies are killed and a + *new sprite must be used (i.e., koopa to koopa shell). */ + let evolve_enemy = (player_dir, typ, spr: Sprite.sprite, obj, context) => + switch typ { + | GKoopa => + let (new_spr, new_obj) = make( + ~dir=obj.dir, + SEnemy(GKoopaShell), + context, + (obj.pos.x, obj.pos.y), + ) + normalize_pos(new_obj.pos, spr.params, new_spr.params) + Some(Enemy(GKoopaShell, new_spr, new_obj)) + | RKoopa => + let (new_spr, new_obj) = make( + ~dir=obj.dir, + SEnemy(RKoopaShell), + context, + (obj.pos.x, obj.pos.y), + ) + normalize_pos(new_obj.pos, spr.params, new_spr.params) + Some(Enemy(RKoopaShell, new_spr, new_obj)) + | GKoopaShell | RKoopaShell => + obj.dir = player_dir + if obj.vel.x != 0. { + obj.vel.x = 0. + } else { + set_vel_to_speed(obj) + } + None + | _ => + obj.kill = true + None + } + + /* Updates the direction of the sprite. */ + let rev_dir = (o, t, s: sprite) => { + reverse_left_right(o) + let old_params = s.params + Sprite.transform_enemy(t, s, o.dir) + normalize_pos(o.pos, old_params, s.params) + } + + /* Used for killing enemies, or to make big Mario into small Mario */ + let dec_health = obj => { + let health = obj.health - 1 + if health == 0 { + obj.kill = true + } else if obj.invuln == 0 { + obj.health = health + } + } + + /* Used for deleting a block and replacing it with a used block */ + let evolve_block = (obj, context) => { + dec_health(obj) + let (new_spr, new_obj) = make(SBlock(QBlockUsed), context, (obj.pos.x, obj.pos.y)) + Block(QBlockUsed, new_spr, new_obj) + } + + /* Used for making a small Mario into a Big Mario */ + let evolve_player = (spr: Sprite.sprite, obj, context) => { + let (new_spr, new_obj) = make(SPlayer(BigM, Standing), context, (obj.pos.x, obj.pos.y)) + normalize_pos(new_obj.pos, spr.params, new_spr.params) + Player(BigM, new_spr, new_obj) + } + + /* Used for spawning items above question mark blocks */ + let spawn_above = (player_dir, obj, typ, context) => { + let item = spawn(SItem(typ), context, (obj.pos.x, obj.pos.y)) + let item_obj = get_obj(item) + item_obj.pos.y = item_obj.pos.y -. snd(get_sprite(item).params.frame_size) + item_obj.dir = opposite_dir(player_dir) + set_vel_to_speed(item_obj) + item + } + + /* Used to get the bounding box. */ + let get_aabb = obj => { + let spr = get_sprite(obj).params + let obj = get_obj(obj) + let (offx, offy) = spr.bbox_offset + let (box, boy) = (obj.pos.x +. offx, obj.pos.y +. offy) + let (sx, sy) = spr.bbox_size + { + center: {x: box +. sx /. 2., y: boy +. sy /. 2.}, + half: {x: sx /. 2., y: sy /. 2.}, + } + } + + let col_bypass = (c1, c2) => { + let o1 = get_obj(c1) and o2 = get_obj(c2) + let ctypes = switch (c1, c2) { + | (Item(_, _, _), Enemy(_, _, _)) + | (Enemy(_, _, _), Item(_, _, _)) + | (Item(_, _, _), Item(_, _, _)) => true + | (Player(_, _, o1), Enemy(_, _, _)) => + if o1.invuln > 0 { + true + } else { + false + } + | _ => false + } + o1.kill || (o2.kill || ctypes) + } + + /* Used for checking if collisions occur. Compares half-widths and half-heights + *and adjusts for when collisions do occur, by changing position so that + *a second collision does not occur again immediately. This causes snapping. */ + let check_collision = (c1, c2) => { + let b1 = get_aabb(c1) and b2 = get_aabb(c2) + let o1 = get_obj(c1) + if col_bypass(c1, c2) { + None + } else { + let vx = b1.center.x -. b2.center.x + let vy = b1.center.y -. b2.center.y + let hwidths = b1.half.x +. b2.half.x + let hheights = b1.half.y +. b2.half.y + if abs_float(vx) < hwidths && abs_float(vy) < hheights { + let ox = hwidths -. abs_float(vx) + let oy = hheights -. abs_float(vy) + if ox >= oy { + if vy > 0. { + o1.pos.y = o1.pos.y +. oy + Some(North) + } else { + o1.pos.y = o1.pos.y -. oy + Some(South) + } + } else if vx > 0. { + o1.pos.x = o1.pos.x +. ox + Some(West) + } else { + o1.pos.x = o1.pos.x -. ox + Some(East) + } + } else { + None + } + } + } + + /* "Kills" the matched object by setting certain parameters for each. */ + let kill = (collid, ctx) => + switch collid { + | Enemy(t, s, o) => + let pos = (o.pos.x, o.pos.y) + let score = if o.score > 0 { + list{Particle.make_score(o.score, pos, ctx)} + } else { + list{} + } + let remains = switch t { + | Goomba => list{Particle.make(GoombaSquish, pos, ctx)} + | _ => list{} + } + \"@"(score, remains) + | Block(t, s, o) => + switch t { + | Brick => + let pos = (o.pos.x, o.pos.y) + let p1 = Particle.make(~vel=(-5., -5.), ~acc=(0., 0.2), BrickChunkL, pos, ctx) + let p2 = Particle.make(~vel=(-3., -4.), ~acc=(0., 0.2), BrickChunkL, pos, ctx) + let p3 = Particle.make(~vel=(3., -4.), ~acc=(0., 0.2), BrickChunkR, pos, ctx) + let p4 = Particle.make(~vel=(5., -5.), ~acc=(0., 0.2), BrickChunkR, pos, ctx) + list{p1, p2, p3, p4} + | _ => list{} + } + | Item(t, s, o) => + switch t { + | Mushroom => list{Particle.make_score(o.score, (o.pos.x, o.pos.y), ctx)} + | _ => list{} + } + | _ => list{} + } +} +module Draw: { + let render: (Sprite.sprite, (float, float)) => unit + + let clear_canvas: Dom_html.canvasElement => unit + + let draw_bgd: (Sprite.sprite, float) => unit + + let render_bbox: (Sprite.sprite, (float, float)) => unit + + let fps: (Dom_html.canvasElement, float) => unit + + let hud: (Dom_html.canvasElement, int, int) => unit + + let game_win: Dom_html.canvasRenderingContext2D => unit + + let game_loss: Dom_html.canvasRenderingContext2D => unit +} = /* Renders a given object on the canvas */ + +/* Clears the canvas */ + +/* Draw the given sprite as a background */ + +/* Draws the axis aligned bounding box of the sprite at the position */ + +/* Draws the fps on the canvas */ + +/* Draw the heads up display */ + +/* Draw the game win screen */ + +/* Draw the game loss screen */ + +{ + open Object + open Sprite + module Html = Dom_html + let document = Html.document + + let get_context = canvas => canvas["getContext"]("2d") + + let render_bbox = (sprite, (posx, posy)) => { + let context = Dom_html.canvasRenderingContext2DToJsObj(sprite.context) + let (bbox, bboy) = sprite.params.bbox_offset + let (bbsx, bbsy) = sprite.params.bbox_size + context["strokeStyle"] = "#FF0000" + context["strokeRect"](posx +. bbox, posy +. bboy, bbsx, bbsy) + } + + /* Draws a sprite onto the canvas. */ + let render = (sprite, (posx, posy)) => { + let context = Dom_html.canvasRenderingContext2DToJsObj(sprite.context) + let (sx, sy) = sprite.params.src_offset + let (sw, sh) = sprite.params.frame_size + let (dx, dy) = (posx, posy) + let (dw, dh) = sprite.params.frame_size + let sx = sx +. float_of_int(sprite.frame.contents) *. sw + /* print_endline (string_of_int !(sprite.frame)); */ + /* context##clearRect(0.,0.,sw, sh); */ + context["drawImage"](sprite.img, sx, sy, sw, sh, dx, dy, dw, dh) + } + + /* Draws two background images, which needs to be done because of the + *constantly changing viewport, which is always at most going to be + *between two background images. */ + let draw_bgd = (bgd, off_x) => { + render(bgd, (-.off_x, 0.)) + render(bgd, (fst(bgd.params.frame_size) -. off_x, 0.)) + } + + /* Used for animation updating. Canvas is cleared each frame and redrawn. */ + let clear_canvas = canvas => { + let canvas = Dom_html.canvasElementToJsObj(canvas) + let context = Dom_html.canvasRenderingContext2DToJsObj(canvas["getContext"]("2d")) + let cwidth = float_of_int(canvas["width"]) + let cheight = float_of_int(canvas["height"]) + \"@@"(ignore, context["clearRect"](0., 0., cwidth, cheight)) + } + + /* Displays the text for score and coins. */ + let hud = (canvas, score, coins) => { + let score_string = string_of_int(score) + let coin_string = string_of_int(coins) + let canvas = Dom_html.canvasElementToJsObj(canvas) + let context = Dom_html.canvasRenderingContext2DToJsObj(canvas["getContext"]("2d")) + \"@@"(ignore, context["font"] = "10px 'Press Start 2P'") + \"@@"( + ignore, + context["fillText"]("Score: " ++ score_string, float_of_int(canvas["width"]) -. 140., 18.), + ) + \"@@"(ignore, context["fillText"]("Coins: " ++ coin_string, 120., 18.)) + } + + /* Displays the fps. */ + let fps = (canvas, fps_val) => { + let fps_str = int_of_float(fps_val) |> string_of_int + let canvas = Dom_html.canvasElementToJsObj(canvas) + let context = Dom_html.canvasRenderingContext2DToJsObj(canvas["getContext"]("2d")) + \"@@"(ignore, context["fillText"](fps_str, 10., 18.)) + } + + /* game_win displays a black screen when you finish a game. */ + let game_win = ctx => { + let ctx = Dom_html.canvasRenderingContext2DToJsObj(ctx) + ctx["rect"](0., 0., 512., 512.) + ctx["fillStyle"] = "black" + ctx["fill"]() + ctx["fillStyle"] = "white" + ctx["font"] = "20px 'Press Start 2P'" + ctx["fillText"]("You win!", 180., 128.) + failwith("Game over.") + } + + /* gave_loss displays a black screen stating a loss to finish that level play. */ + let game_loss = ctx => { + let ctx = Dom_html.canvasRenderingContext2DToJsObj(ctx) + ctx["rect"](0., 0., 512., 512.) + ctx["fillStyle"] = "black" + ctx["fill"]() + ctx["fillStyle"] = "white" + ctx["font"] = "20px 'Press Start 2P'" + ctx["fillText"]("GAME OVER. You lose!", 60., 128.) + failwith("Game over.") + } + + let draw_background_color = canvas => failwith("todo") +} +module Viewport: { + open Actors + + type viewport = { + pos: Actors.xy /* Absolute position of viewport relative to map */, + v_dim: Actors.xy /* Dimensions of viewport */, + m_dim: Actors.xy /* Dimensions of map */, + } + + /* Makes a new viewport of viewport dimensions and map dimensions */ + let make: ((float, float), (float, float)) => viewport + + /* Calculates the viewport origin point */ + let calc_viewport_point: (float, float, float) => float + + /* Whether the supplied position is outside of the viewport */ + let in_viewport: (viewport, Actors.xy) => bool + + /* Whether the supplied position is below the viewport */ + let out_of_viewport_below: (viewport, float) => bool + + /* Converts absolute coordinates to viewport coodinates */ + let coord_to_viewport: (viewport, Actors.xy) => Actors.xy + + /* Update the viewport */ + let update: (viewport, Actors.xy) => viewport +} = { + open Actors + + type viewport = { + pos: Actors.xy, + v_dim: Actors.xy, + m_dim: Actors.xy, + } + + let make = ((vx, vy), (mx, my)) => { + pos: {x: 0., y: 0.}, + v_dim: {x: vx, y: vy}, + m_dim: {x: mx, y: my}, + } + + /* Calculates the viewport origin coordinate given the centering coordinate + * [cc], the canvas coordinate [vc], and the map coordinate [mc]. This function + * works for both x and y. At the extreme points, it will ensure that the + * viewport is always within bounds of the map, even if it is no longer + * centered about the origin point. */ + let calc_viewport_point = (cc, vc, mc) => { + let vc_half = vc /. 2. + min(max(cc -. vc_half, 0.), min(mc -. vc, abs_float(cc -. vc_half))) + } + + /* Returns whether a coordinate pair [pos] is inside the viewport [v] */ + let in_viewport = (v, pos) => { + let margin = 32. + let (v_min_x, v_max_x) = (v.pos.x -. margin, v.pos.x +. v.v_dim.x) + let (v_min_y, v_max_y) = (v.pos.y -. margin, v.pos.y +. v.v_dim.y) + let (x, y) = (pos.x, pos.y) + x >= v_min_x && (x <= v_max_x && (y >= v_min_y && y <= v_max_y)) + } + + /* Returns whether an object is outside of the viewport and below it. This is + * useful for determining whether to process falling out of screen normally. */ + let out_of_viewport_below = (v, y) => { + let v_max_y = v.pos.y +. v.v_dim.y + y >= v_max_y + } + + /* Converts a x,y [coord] pair in absolute coordinates to coordinates relative + * to the viewport */ + let coord_to_viewport = (viewport, coord) => { + x: coord.x -. viewport.pos.x, + y: coord.y -. viewport.pos.y, + } + + /* Update the viewport [vpt] given the new center x,y coordinate pair [ctr] */ + let update = (vpt, ctr) => { + let new_x = calc_viewport_point(ctr.x, vpt.v_dim.x, vpt.m_dim.x) + let new_y = calc_viewport_point(ctr.y, vpt.v_dim.y, vpt.m_dim.y) + let pos = {x: new_x, y: new_y} + {...vpt, pos} + } +} +module Director: { + let update_loop: ( + Dom_html.canvasElement, + (Object.collidable, list), + (float, float), + ) => unit + + let keydown: Dom.keyboardEvent => bool + + let keyup: Dom.keyboardEvent => bool +} = /* Initiates the main game loop */ + +/* Keydown event handler function */ + +/* Keyup event handler function */ + +{ + open Sprite + open Object + open Actors + open Viewport + open Particle + + /* Represents the values of relevant key bindings. */ + type keys = { + mutable left: bool, + mutable right: bool, + mutable up: bool, + mutable down: bool, + mutable bbox: int, + } + + /* st represents the state of the game. It includes a background sprite (e.g., + * (e.g., hills), a context (used for rendering onto the page), a viewport + * (used for moving the player's "camera"), a score (which is kept track + * throughout the game), coins (also kept track through the game), + * a multiplier (used for when you kill multiple enemies before ever touching + * the ground, as in the actual Super Mario), and a game_over bool (which + * is only true when the game is over). */ + type st = { + bgd: sprite, + ctx: Dom_html.canvasRenderingContext2D, + vpt: viewport, + map: float, + mutable score: int, + mutable coins: int, + mutable multiplier: int, + mutable game_over: bool, + } + + /* pressed_keys instantiates the keys. */ + let pressed_keys = { + left: false, + right: false, + up: false, + down: false, + bbox: 0, + } + + let collid_objs = ref(list{}) /* List of next iteration collidable objects */ + let particles = ref(list{}) /* List of next iteration particles */ + let last_time = ref(0.) /* Used for calculating fps */ + + /* Calculates fps as the difference between [t0] and [t1] */ + let calc_fps = (t0, t1) => { + let delta = (t1 -. t0) /. 1000. + 1. /. delta + } + + /* Adds [i] to the score in [state] */ + let update_score = (state, i) => state.score = state.score + i + + /* player_attack_enemy is called for a player hitting an enemy from the north. + *This causes the player to either kill the enemy or move the enemy, in the + *case that the enemy is a shell. Invulnerability, jumping, and grounded + *are used for fine tuning the movements. */ + let player_attack_enemy = (s1, o1, typ, s2, o2, state, context) => { + o1.invuln = 10 + o1.jumping = false + o1.grounded = true + switch typ { + | GKoopaShell | RKoopaShell => + let r2 = evolve_enemy(o1.dir, typ, s2, o2, context) + o1.vel.y = -.dampen_jump + o1.pos.y = o1.pos.y -. 5. + (None, r2) + | _ => + dec_health(o2) + o1.vel.y = -.dampen_jump + if state.multiplier == 8 { + update_score(state, 800) + o2.score = 800 + (None, evolve_enemy(o1.dir, typ, s2, o2, context)) + } else { + let score = 100 * state.multiplier + update_score(state, score) + o2.score = score + state.multiplier = state.multiplier * 2 + (None, evolve_enemy(o1.dir, typ, s2, o2, context)) + } + } + } + + /* enemy_attack_player is used when an enemy kills a player. */ + let enemy_attack_player = (s1, o1: Object.obj, t2, s2, o2: Object.obj, context) => + switch t2 { + | GKoopaShell | RKoopaShell => + let r2 = if o2.vel.x == 0. { + evolve_enemy(o1.dir, t2, s2, o2, context) + } else { + dec_health(o1) + o1.invuln = invuln + None + } + (None, r2) + | _ => + dec_health(o1) + o1.invuln = invuln + (None, None) + } + + /* In the case that two enemies collide, they are to reverse directions. However, + *in the case that one or more of the two enemies is a koopa shell, then + *the koopa shell kills the other enemy. */ + let col_enemy_enemy = (t1, s1, o1, t2, s2, o2, dir) => + switch (t1, t2) { + | (GKoopaShell, GKoopaShell) + | (GKoopaShell, RKoopaShell) + | (RKoopaShell, RKoopaShell) + | (RKoopaShell, GKoopaShell) => + dec_health(o1) + dec_health(o2) + (None, None) + | (RKoopaShell, _) | (GKoopaShell, _) => + if o1.vel.x == 0. { + rev_dir(o2, t2, s2) + (None, None) + } else { + dec_health(o2) + (None, None) + } + | (_, RKoopaShell) | (_, GKoopaShell) => + if o2.vel.x == 0. { + rev_dir(o1, t1, s1) + (None, None) + } else { + dec_health(o1) + (None, None) + } + | (_, _) => + switch dir { + | West | East => + rev_dir(o1, t1, s1) + rev_dir(o2, t2, s2) + (None, None) + | _ => (None, None) + } + } + + /* Gets the object at a given position */ + let obj_at_pos = (dir, pos: xy, collids: list): list => + switch dir { + | Left => + List.filter( + (col: Object.collidable) => + get_obj(col).pos.y == pos.y && get_obj(col).pos.x == pos.x -. 16., + collids, + ) + | _ => + List.filter( + (col: Object.collidable) => + get_obj(col).pos.y == pos.y && get_obj(col).pos.x == pos.x +. 16., + collids, + ) + } + + /* Returns whether the object at a given position is a block */ + let is_block = (dir, pos, collids) => + switch obj_at_pos(dir, pos, collids) { + | list{} => false + | list{Block(_, _, _)} => true + | _ => false + } + + /* Returns whether the given object is a red koopa */ + let is_rkoopa = collid => + switch collid { + | Enemy(RKoopa, _, _) => true + | _ => false + } + + /* Process collision is called to match each of the possible collisions that + * may occur. Returns a pair of collidable options, representing objects that + * were created from the existing ones. That is, the first element represents + * a new item spawned as a result of the first collidable. None indicates that + * no new item should be spawned. Transformations to existing objects occur + * mutably, as many changes are side-effectual. */ + let process_collision = ( + dir: Actors.dir_2d, + c1: Object.collidable, + c2: Object.collidable, + state: st, + ): (option, option) => { + let context = state.ctx + switch (c1, c2, dir) { + | (Player(_, s1, o1), Enemy(typ, s2, o2), South) + | (Enemy(typ, s2, o2), Player(_, s1, o1), North) => + player_attack_enemy(s1, o1, typ, s2, o2, state, context) + | (Player(_, s1, o1), Enemy(t2, s2, o2), _) + | (Enemy(t2, s2, o2), Player(_, s1, o1), _) => + enemy_attack_player(s1, o1, t2, s2, o2, context) + | (Player(_, s1, o1), Item(t2, s2, o2), _) + | (Item(t2, s2, o2), Player(_, s1, o1), _) => + switch t2 { + | Mushroom => + dec_health(o2) + if o1.health == 2 { + () + } else { + o1.health = o1.health + 1 + } + o1.vel.x = 0. + o1.vel.y = 0. + update_score(state, 1000) + o2.score = 1000 + (None, None) + | Coin => + state.coins = state.coins + 1 + dec_health(o2) + update_score(state, 100) + (None, None) + | _ => + dec_health(o2) + update_score(state, 1000) + (None, None) + } + | (Enemy(t1, s1, o1), Enemy(t2, s2, o2), dir) => col_enemy_enemy(t1, s1, o1, t2, s2, o2, dir) + | (Enemy(t1, s1, o1), Block(t2, s2, o2), East) + | (Enemy(t1, s1, o1), Block(t2, s2, o2), West) => + switch (t1, t2) { + /* FIXME */ + | (RKoopaShell, Brick) | (GKoopaShell, Brick) => + dec_health(o2) + reverse_left_right(o1) + (None, None) + | (RKoopaShell, QBlock(typ)) | (GKoopaShell, QBlock(typ)) => + let updated_block = evolve_block(o2, context) + let spawned_item = spawn_above(o1.dir, o2, typ, context) + rev_dir(o1, t1, s1) + (Some(updated_block), Some(spawned_item)) + | (_, _) => + rev_dir(o1, t1, s1) + (None, None) + } + | (Item(_, s1, o1), Block(typ2, s2, o2), East) + | (Item(_, s1, o1), Block(typ2, s2, o2), West) => + reverse_left_right(o1) + (None, None) + | (Enemy(_, s1, o1), Block(typ2, s2, o2), _) + | (Item(_, s1, o1), Block(typ2, s2, o2), _) => + collide_block(dir, o1) + (None, None) + | (Player(t1, s1, o1), Block(t, s2, o2), North) => + switch t { + | QBlock(typ) => + let updated_block = evolve_block(o2, context) + let spawned_item = spawn_above(o1.dir, o2, typ, context) + collide_block(dir, o1) + (Some(spawned_item), Some(updated_block)) + | Brick => + if t1 == BigM { + collide_block(dir, o1) + dec_health(o2) + (None, None) + } else { + collide_block(dir, o1) + (None, None) + } + | Panel => + Draw.game_win(state.ctx) + (None, None) + | _ => + collide_block(dir, o1) + (None, None) + } + | (Player(_, s1, o1), Block(t, s2, o2), _) => + switch t { + | Panel => + Draw.game_win(state.ctx) + (None, None) + | _ => + switch dir { + | South => + state.multiplier = 1 + collide_block(dir, o1) + (None, None) + | _ => + collide_block(dir, o1) + (None, None) + } + } + | (_, _, _) => (None, None) + } + } + + /* Run the broad phase object filtering */ + let broad_phase = (collid, all_collids, state) => { + let obj = get_obj(collid) + List.filter( + c => + in_viewport(state.vpt, obj.pos) || + (is_player(collid) || + out_of_viewport_below(state.vpt, obj.pos.y)), + all_collids, + ) + } + + /* narrow_phase of collision is used in order to continuously loop through + *each of the collidable objects to constantly check if collisions are + *occurring. */ + let rec narrow_phase = (c, cs, state) => { + let rec narrow_helper = (c, cs, state, acc) => + switch cs { + | list{} => acc + | list{h, ...t} => + let c_obj = get_obj(c) + let new_objs = if !equals(c, h) { + switch Object.check_collision(c, h) { + | None => (None, None) + | Some(dir) => + if get_obj(h).id != c_obj.id { + /* ( (if (if is_rkoopa c then + begin match c_obj.dir with + | Left -> is_block c_obj.dir {x= c_obj.pos.x -. 16.; y= c_obj.pos.y -. 27.} cs + | _ -> is_block c_obj.dir {x= c_obj.pos.x +. 16.; y= c_obj.pos.y -. 27.} cs + end else false) then rev_dir c_obj RKoopa (Object.get_sprite c) else + ());*/ + process_collision(dir, c, h, state) + } else { + (None, None) + } + } + } else { + (None, None) + } + let acc = switch new_objs { + | (None, Some(o)) => list{o, ...acc} + | (Some(o), None) => list{o, ...acc} + | (Some(o1), Some(o2)) => list{o1, o2, ...acc} + | (None, None) => acc + } + + narrow_helper(c, t, state, acc) + } + narrow_helper(c, cs, state, list{}) + } + + /* This is an optimization setp to determine which objects require narrow phase + * checking. This excludes static collidables, allowing collision to only be + * checked with moving objects. This method is called once per collidable. + * Collision detection proceeds as follows: + * 1. Broad phase - filter collidables that cannot possibly collide with + * this object. + * 2. Narrow phase - compare against all objects to determine whether there + * is a collision, and process the collision. + * This method returns a list of objects that are created, which should be + * added to the list of collidables for the next iteration. + * */ + let check_collisions = (collid, all_collids, state) => + switch collid { + | Block(_, _, _) => list{} + | _ => + let broad = broad_phase(collid, all_collids, state) + narrow_phase(collid, broad, state) + } + + /* Returns whether the bounding box should be drawn */ + let check_bbox_enabled = () => pressed_keys.bbox == 1 + + /* update_collidable is the primary update method for collidable objects, + * checking the collision, updating the object, and drawing to the canvas. */ + let update_collidable = (state, collid: Object.collidable, all_collids) => { + /* TODO: optimize. Draw static elements only once */ + let obj = Object.get_obj(collid) + let spr = Object.get_sprite(collid) + obj.invuln = if obj.invuln > 0 { + obj.invuln - 1 + } else { + 0 + } + /* Prevent position from being updated outside of viewport */ + let viewport_filter = + in_viewport(state.vpt, obj.pos) || + (is_player(collid) || + out_of_viewport_below(state.vpt, obj.pos.y)) + if !obj.kill && viewport_filter { + obj.grounded = false + Object.process_obj(obj, state.map) + /* Run collision detection if moving object */ + let evolved = check_collisions(collid, all_collids, state) + /* Render and update animation */ + let vpt_adj_xy = coord_to_viewport(state.vpt, obj.pos) + Draw.render(spr, (vpt_adj_xy.x, vpt_adj_xy.y)) + if check_bbox_enabled() { + Draw.render_bbox(spr, (vpt_adj_xy.x, vpt_adj_xy.y)) + } + + if obj.vel.x != 0. || !is_enemy(collid) { + Sprite.update_animation(spr) + } + evolved + } else { + list{} + } + } + + /* Converts a keypress to a list of control keys, allowing more than one key + * to be processed each frame. */ + let translate_keys = () => { + let k = pressed_keys + let ctrls = list{(k.left, CLeft), (k.right, CRight), (k.up, CUp), (k.down, CDown)} + List.fold_left((a, x) => + if fst(x) { + list{snd(x), ...a} + } else { + a + } + , list{}, ctrls) + } + + /* run_update is used to update all of the collidables at once. Primarily used + * as a wrapper method. This method is necessary to differentiate between + * the player collidable and the remaining collidables, as special operations + * such as viewport centering only occur with the player. */ + let run_update_collid = (state, collid, all_collids) => + switch collid { + | Player(t, s, o) as p => + let keys = translate_keys() + o.crouch = false + let player = switch Object.update_player(o, keys, state.ctx) { + | None => p + | Some(new_typ, new_spr) => + Object.normalize_pos(o.pos, s.params, new_spr.params) + Player(new_typ, new_spr, o) + } + let evolved = update_collidable(state, player, all_collids) + collid_objs := \"@"(collid_objs.contents, evolved) + player + | _ => + let obj = get_obj(collid) + let evolved = update_collidable(state, collid, all_collids) + if !obj.kill { + collid_objs := list{collid, ...\"@"(collid_objs.contents, evolved)} + } + let new_parts = if obj.kill { + Object.kill(collid, state.ctx) + } else { + list{} + } + particles := \"@"(particles.contents, new_parts) + collid + } + + /* Primary update function to update and persist a particle */ + let run_update_particle = (state, part) => { + Particle.process(part) + let x = part.pos.x -. state.vpt.pos.x and y = part.pos.y -. state.vpt.pos.y + Draw.render(part.params.sprite, (x, y)) + if !part.kill { + particles := list{part, ...particles.contents} + } + } + + /* update_loop is constantly being called to check for collisions and to + *update each of the objects in the game. */ + let update_loop = (canvas, (player, objs), map_dim) => { + let scale = 1. + let ctx = Dom_html.canvasElementToJsObj(canvas)["getContext"]("2d") + let cwidth = float_of_int(Dom_html.canvasElementToJsObj(canvas)["width"]) /. scale + let cheight = float_of_int(Dom_html.canvasElementToJsObj(canvas)["height"]) /. scale + let viewport = Viewport.make((cwidth, cheight), map_dim) + let state = { + bgd: Sprite.make_bgd(ctx), + vpt: Viewport.update(viewport, get_obj(player).pos), + ctx, + score: 0, + coins: 0, + multiplier: 1, + map: snd(map_dim), + game_over: false, + } + Dom_html.canvasRenderingContext2DToJsObj(state.ctx)["scale"](scale, scale) + let rec update_helper = (time, state, player, objs, parts) => + if state.game_over == true { + Draw.game_win(state.ctx) + } else { + collid_objs := list{} + particles := list{} + + let fps = calc_fps(last_time.contents, time) + last_time := time + + Draw.clear_canvas(canvas) + + /* Parallax background */ + let vpos_x_int = int_of_float(state.vpt.pos.x /. 5.) + let bgd_width = int_of_float(fst(state.bgd.params.frame_size)) + Draw.draw_bgd(state.bgd, float_of_int(mod(vpos_x_int, bgd_width))) + + let player = run_update_collid(state, player, objs) + + if get_obj(player).kill == true { + Draw.game_loss(state.ctx) + } else { + let state = { + ...state, + vpt: Viewport.update(state.vpt, get_obj(player).pos), + } + List.iter(obj => ignore(run_update_collid(state, obj, objs)), objs) + List.iter(part => run_update_particle(state, part), parts) + Draw.fps(canvas, fps) + Draw.hud(canvas, state.score, state.coins) + \"@@"( + ignore, + Dom_html.requestAnimationFrame((t: float) => + update_helper(t, state, player, collid_objs.contents, particles.contents) + ), + ) + } + } + update_helper(0., state, player, objs, list{}) + } + + /* Keydown event handler translates a key press */ + let keydown = evt => { + let evt = Dom_html.keyboardEventToJsObj(evt) + let () = switch evt["keyCode"] { + | 38 | 32 | 87 => pressed_keys.up = true + | 39 | 68 => pressed_keys.right = true + | 37 | 65 => pressed_keys.left = true + | 40 | 83 => pressed_keys.down = true + | 66 => pressed_keys.bbox = mod(pressed_keys.bbox + 1, 2) + | _ => () + } + true + } + + /* Keyup event handler translates a key release */ + let keyup = evt => { + let evt = Dom_html.keyboardEventToJsObj(evt) + let () = switch evt["keyCode"] { + | 38 | 32 | 87 => pressed_keys.up = false + | 39 | 68 => pressed_keys.right = false + | 37 | 65 => pressed_keys.left = false + | 40 | 83 => pressed_keys.down = false + | _ => () + } + true + } +} +module Procedural_generator: { + open Object + open Actors + + type obj_coord + + let init: unit => unit + + /* Procedurally generates a new map of default size */ + let generate: (float, float, Dom_html.canvasRenderingContext2D) => (collidable, list) +} = { + open Actors + open Object + + /* Note: Canvas is 512 by 256 (w*h) -> 32 by 16 blocks */ + + /* Holds obj typ and its coordinates. (int, (x-coord, y-coord)) */ + type obj_coord = (int, (float, float)) + + /* Checks if the given location checkloc is already part of the list of locations + * in loclist. */ + let rec mem_loc = (checkloc: (float, float), loclist: list): bool => + switch loclist { + | list{} => false + | list{h, ...t} => + if checkloc == snd(h) { + true + } else { + mem_loc(checkloc, t) + } + } + + /* Converts list of locations from blocksize to pixelsize by multiplying (x,y) by + * 16. */ + let rec convert_list = (lst: list): list => + switch lst { + | list{} => list{} + | list{h, ...t} => + \"@"(list{(fst(h), (fst(snd(h)) *. 16., snd(snd(h)) *. 16.))}, convert_list(t)) + } + + /* Chooses what type of enemy should be instantiated given typ number */ + let choose_enemy_typ = (typ: int): enemy_typ => + switch typ { + | 0 => RKoopa + | 1 => GKoopa + | 2 => Goomba + | _ => failwith("Shouldn't reach here") + } + + /* Chooses what type of block should be instantiated given typ number */ + let choose_sblock_typ = (typ: int): block_typ => + switch typ { + | 0 => Brick + | 1 => UnBBlock + | 2 => Cloud + | 3 => QBlock(Mushroom) + | 4 => Ground + | _ => failwith("Shouldn't reach here") + } + + /* Optimizes lst such that there are no two items in the list that have the same + * coordinates. If there is one, it is removed. */ + let rec avoid_overlap = (lst: list, currentLst: list): list => + switch lst { + | list{} => list{} + | list{h, ...t} => + if mem_loc(snd(h), currentLst) { + avoid_overlap(t, currentLst) + } else { + \"@"(list{h}, avoid_overlap(t, currentLst)) + } + } + + /* Gets rid of objects with coordinates in the ending frame, within 128 pixels of + * the start, at the very top, and two blocks from the ground. */ + let rec trim_edges = (lst: list, blockw: float, blockh: float): list => + switch lst { + | list{} => list{} + | list{h, ...t} => + let cx = fst(snd(h)) + let cy = snd(snd(h)) + let pixx = blockw *. 16. + let pixy = blockh *. 16. + if cx < 128. || (pixx -. cx < 528. || (cy == 0. || pixy -. cy < 48.)) { + trim_edges(t, blockw, blockh) + } else { + \"@"(list{h}, trim_edges(t, blockw, blockh)) + } + } + + /* Generates a stair formation with block typ being dependent on typ. This type + * of stair formation requires that the first step be on the ground. */ + let generate_ground_stairs = (cbx, cby, typ) => { + let four = list{ + (typ, (cbx, cby)), + (typ, (cbx +. 1., cby)), + (typ, (cbx +. 2., cby)), + (typ, (cbx +. 3., cby)), + } + let three = list{ + (typ, (cbx +. 1., cby -. 1.)), + (typ, (cbx +. 2., cby -. 1.)), + (typ, (cbx +. 3., cby -. 1.)), + } + let two = list{(typ, (cbx +. 2., cby -. 2.)), (typ, (cbx +. 3., cby -. 2.))} + let one = list{(typ, (cbx +. 3., cby -. 3.))} + \"@"(four, \"@"(three, \"@"(two, one))) + } + + /* Generates a stair formation going upwards. */ + let generate_airup_stairs = (cbx, cby, typ) => { + let one = list{(typ, (cbx, cby)), (typ, (cbx +. 1., cby))} + let two = list{(typ, (cbx +. 3., cby -. 1.)), (typ, (cbx +. 4., cby -. 1.))} + let three = list{ + (typ, (cbx +. 4., cby -. 2.)), + (typ, (cbx +. 5., cby -. 2.)), + (typ, (cbx +. 6., cby -. 2.)), + } + \"@"(one, \"@"(two, three)) + } + + /* Generates a stair formation going downwards */ + let generate_airdown_stairs = (cbx, cby, typ) => { + let three = list{(typ, (cbx, cby)), (typ, (cbx +. 1., cby)), (typ, (cbx +. 2., cby))} + let two = list{(typ, (cbx +. 2., cby +. 1.)), (typ, (cbx +. 3., cby +. 1.))} + let one = list{(typ, (cbx +. 5., cby +. 2.)), (typ, (cbx +. 6., cby +. 2.))} + \"@"(three, \"@"(two, one)) + } + + /* Generates a cloud block platform with some length num. */ + let rec generate_clouds = (cbx, cby, typ, num) => + if num == 0 { + list{} + } else { + \"@"(list{(typ, (cbx, cby))}, generate_clouds(cbx +. 1., cby, typ, num - 1)) + } + + /* Generates an obj_coord list (typ, coordinates) of coins to be placed. */ + let rec generate_coins = (block_coord: list): list => { + let place_coin = Random.int(2) + switch block_coord { + | list{} => list{} + | list{h, ...t} => + if place_coin == 0 { + let xc = fst(snd(h)) + let yc = snd(snd(h)) + \"@"(list{(0, (xc, yc -. 16.))}, generate_coins(t)) + } else { + generate_coins(t) + } + } + } + + /* Chooses the form of the blocks to be placed. + * When called, leaves a 1 block gap from canvas size. + * 1. If current xblock or yblock is greater than canvas width or height + * respectively, return an empty list. + * 2. If current xblock or yblock is within 10 blocks of the left and right sides + * of the level map, prevent any objects from being initialized. + * 3. Else call helper methods to created block formations and return obj_coord + * list. + * */ + let choose_block_pattern = ( + blockw: float, + blockh: float, + cbx: float, + cby: float, + prob: int, + ): list => + if cbx > blockw || cby > blockh { + list{} + } else { + let block_typ = Random.int(4) + let stair_typ = Random.int(2) + let life_block_chance = Random.int(5) + let middle_block = if life_block_chance == 0 { + 3 + } else { + stair_typ + } + let obj_coord = switch prob { + | 0 => + if blockw -. cbx > 2. { + list{ + (stair_typ, (cbx, cby)), + (middle_block, (cbx +. 1., cby)), + (stair_typ, (cbx +. 2., cby)), + } + } else if blockw -. cbx > 1. { + list{(block_typ, (cbx, cby)), (block_typ, (cbx +. 1., cby))} + } else { + list{(block_typ, (cbx, cby))} + } + | 1 => + let num_clouds = Random.int(5) + 5 + if cby < 5. { + generate_clouds(cbx, cby, 2, num_clouds) + } else { + list{} + } + | 2 => + if blockh -. cby == 1. { + generate_ground_stairs(cbx, cby, stair_typ) + } else { + list{} + } + | 3 => + if stair_typ == 0 && blockh -. cby > 3. { + generate_airdown_stairs(cbx, cby, stair_typ) + } else if blockh -. cby > 2. { + generate_airup_stairs(cbx, cby, stair_typ) + } else { + list{(stair_typ, (cbx, cby))} + } + | 4 => + if cby +. 3. -. blockh == 2. { + list{(stair_typ, (cbx, cby))} + } else if cby +. 3. -. blockh == 1. { + list{(stair_typ, (cbx, cby)), (stair_typ, (cbx, cby +. 1.))} + } else { + list{ + (stair_typ, (cbx, cby)), + (stair_typ, (cbx, cby +. 1.)), + (stair_typ, (cbx, cby +. 2.)), + } + } + | 5 => list{(3, (cbx, cby))} + | _ => failwith("Shouldn't reach here") + } + obj_coord + } + + /* Generates a list of enemies to be placed on the ground. */ + let rec generate_enemies = ( + blockw: float, + blockh: float, + cbx: float, + cby: float, + acc: list, + ) => + if cbx > blockw -. 32. { + list{} + } else if cby > blockh -. 1. || cbx < 15. { + generate_enemies(blockw, blockh, cbx +. 1., 0., acc) + } else if mem_loc((cbx, cby), acc) || cby == 0. { + generate_enemies(blockw, blockh, cbx, cby +. 1., acc) + } else { + let prob = Random.int(30) + let enem_prob = 3 + if prob < enem_prob && blockh -. 1. == cby { + let enemy = list{(prob, (cbx *. 16., cby *. 16.))} + \"@"(enemy, generate_enemies(blockw, blockh, cbx, cby +. 1., acc)) + } else { + generate_enemies(blockw, blockh, cbx, cby +. 1., acc) + } + } + + /* Generates a list of enemies to be placed upon the block objects. */ + let rec generate_block_enemies = (block_coord: list): list => { + let place_enemy = Random.int(20) + let enemy_typ = Random.int(3) + switch block_coord { + | list{} => list{} + | list{h, ...t} => + if place_enemy == 0 { + let xc = fst(snd(h)) + let yc = snd(snd(h)) + \"@"(list{(enemy_typ, (xc, yc -. 16.))}, generate_block_enemies(t)) + } else { + generate_block_enemies(t) + } + } + } + + /* Generates an obj_coord list (typ, coordinates) of blocks to be placed. */ + let rec generate_block_locs = ( + blockw: float, + blockh: float, + cbx: float, + cby: float, + acc: list, + ): list => + if blockw -. cbx < 33. { + acc + } else if cby > blockh -. 1. { + generate_block_locs(blockw, blockh, cbx +. 1., 0., acc) + } else if mem_loc((cbx, cby), acc) || cby == 0. { + generate_block_locs(blockw, blockh, cbx, cby +. 1., acc) + } else { + let prob = Random.int(100) + let block_prob = 5 + if prob < block_prob { + let newacc = choose_block_pattern(blockw, blockh, cbx, cby, prob) + let undup_lst = avoid_overlap(newacc, acc) + let called_acc = \"@"(acc, undup_lst) + generate_block_locs(blockw, blockh, cbx, cby +. 1., called_acc) + } else { + generate_block_locs(blockw, blockh, cbx, cby +. 1., acc) + } + } + + /* Generates the ending item panel at the end of the level. Games ends upon + * collision with player. */ + let generate_panel = ( + context: Dom_html.canvasRenderingContext2D, + blockw: float, + blockh: float, + ): collidable => { + let ob = Object.spawn( + SBlock(Panel), + context, + (blockw *. 16. -. 256., blockh *. 16. *. 2. /. 3.), + ) + ob + } + + /* Generates the list of brick locations needed to display the ground. + * 1/10 chance that a ground block is skipped each call to create holes. */ + let rec generate_ground = (blockw: float, blockh: float, inc: float, acc: list): list< + obj_coord, + > => + if inc > blockw { + acc + } else if inc > 10. { + let skip = Random.int(10) + let newacc = \"@"(acc, list{(4, (inc *. 16., blockh *. 16.))}) + if skip == 7 && blockw -. inc > 32. { + generate_ground(blockw, blockh, inc +. 1., acc) + } else { + generate_ground(blockw, blockh, inc +. 1., newacc) + } + } else { + let newacc = \"@"(acc, list{(4, (inc *. 16., blockh *. 16.))}) + generate_ground(blockw, blockh, inc +. 1., newacc) + } + + /* Converts the obj_coord list called by generate_block_locs to a list of objects + * with the coordinates given from the obj_coord list. */ + let rec convert_to_block_obj = ( + lst: list, + context: Dom_html.canvasRenderingContext2D, + ): list => + switch lst { + | list{} => list{} + | list{h, ...t} => + let sblock_typ = choose_sblock_typ(fst(h)) + let ob = Object.spawn(SBlock(sblock_typ), context, snd(h)) + \"@"(list{ob}, convert_to_block_obj(t, context)) + } + + /* Converts the obj_coord list called by generate_enemies to a list of objects + * with the coordinates given from the obj_coord list. */ + let rec convert_to_enemy_obj = ( + lst: list, + context: Dom_html.canvasRenderingContext2D, + ): list => + switch lst { + | list{} => list{} + | list{h, ...t} => + let senemy_typ = choose_enemy_typ(fst(h)) + let ob = Object.spawn(SEnemy(senemy_typ), context, snd(h)) + \"@"(list{ob}, convert_to_enemy_obj(t, context)) + } + + /* Converts the list of coordinates into a list of Coin objects */ + let rec convert_to_coin_obj = ( + lst: list, + context: Dom_html.canvasRenderingContext2D, + ): list => + switch lst { + | list{} => list{} + | list{h, ...t} => + let sitem_typ = Coin + let ob = Object.spawn(SItem(sitem_typ), context, snd(h)) + \"@"(list{ob}, convert_to_coin_obj(t, context)) + } + + /* Procedurally generates a list of collidables given canvas width, height and + * context. Arguments block width (blockw) and block height (blockh) are in + * block form, not pixels. */ + let generate_helper = ( + blockw: float, + blockh: float, + cx: float, + cy: float, + context: Dom_html.canvasRenderingContext2D, + ): list => { + let block_locs = generate_block_locs(blockw, blockh, 0., 0., list{}) + let converted_block_locs = trim_edges(convert_list(block_locs), blockw, blockh) + let obj_converted_block_locs = convert_to_block_obj(converted_block_locs, context) + let ground_blocks = generate_ground(blockw, blockh, 0., list{}) + let obj_converted_ground_blocks = convert_to_block_obj(ground_blocks, context) + let block_locations = \"@"(block_locs, ground_blocks) + let all_blocks = \"@"(obj_converted_block_locs, obj_converted_ground_blocks) + let enemy_locs = generate_enemies(blockw, blockh, 0., 0., block_locations) + let obj_converted_enemies = convert_to_enemy_obj(enemy_locs, context) + let coin_locs = generate_coins(converted_block_locs) + let undup_coin_locs = trim_edges(avoid_overlap(coin_locs, converted_block_locs), blockw, blockh) + let converted_block_coin_locs = \"@"(converted_block_locs, coin_locs) + let enemy_block_locs = generate_block_enemies(converted_block_locs) + let undup_enemy_block_locs = avoid_overlap(enemy_block_locs, converted_block_coin_locs) + let obj_enemy_blocks = convert_to_enemy_obj(undup_enemy_block_locs, context) + let coin_objects = convert_to_coin_obj(undup_coin_locs, context) + let obj_panel = generate_panel(context, blockw, blockh) + \"@"( + all_blocks, + \"@"(obj_converted_enemies, \"@"(coin_objects, \"@"(obj_enemy_blocks, list{obj_panel}))), + ) + } + + /* Main function called to procedurally generate the level map. w and h args + * are in pixel form. Converts to block form to call generate_helper. Spawns + * the list of collidables received from generate_helper to display on canvas. */ + let generate = (w: float, h: float, context: Dom_html.canvasRenderingContext2D): ( + collidable, + list, + ) => { + let blockw = w /. 16. + let blockh = h /. 16. -. 1. + let collide_list = generate_helper(blockw, blockh, 0., 0., context) + let player = Object.spawn(SPlayer(SmallM, Standing), context, (100., 224.)) + (player, collide_list) + } + + /* Makes sure level map is uniquely generated at each call. */ + let init = () => Random.self_init() +} +module Main = { + open Actors + open Sprite + open Object + module Html = Dom_html + module Pg = Procedural_generator + + let loadCount = ref(0) + let imgsToLoad = 4 + let level_width = 2400. + let level_height = 256. + + /* Canvas is chosen from the index.html file. The context is obtained from + *the canvas. Listeners are added. A level is generated and the general + *update_loop method is called to make the level playable. */ + let load = _ => { + Random.self_init() + let canvas_id = "canvas" + let canvas = switch Dom_html.getElementById(Dom_html.document, canvas_id) { + | None => + Js.log("cant find canvas " ++ canvas_id ++ "") + failwith("fail") + | Some(el) => Dom_html.elementToCanvasElement(el) + } + + let context = Dom_html.canvasElementToJsObj(canvas)["getContext"]("2d") + let _ = Dom_html.addEventListener(Dom_html.document, "keydown", Director.keydown, true) + let _ = Dom_html.addEventListener(Dom_html.document, "keyup", Director.keyup, true) + let () = Pg.init() + let _ = Director.update_loop( + canvas, + Pg.generate(level_width, level_height, context), + (level_width, level_height), + ) + print_endline("asd") + () + } + + let inc_counter = _ => { + loadCount := loadCount.contents + 1 + if loadCount.contents == imgsToLoad { + load() + } else { + () + } + } + + /* Used for concurrency issues. */ + let preload = _ => { + let root_dir = "sprites/" + let imgs = list{"blocks.png", "items.png", "enemies.png", "mario-small.png"} + List.map(img_src => { + let img_src = root_dir ++ img_src + let img = Html.createImg(Dom_html.document) + Dom_html.imageElementToJsObj(img)["src"] = img_src + ignore( + Dom_html.addEventListenerImg( + img, + "load", + ev => { + inc_counter() + true + }, + true, + ), + ) + }, imgs) + } + + let _ = Dom_html.windowToJsObj(Dom_html.window)["onload"] = _ => { + ignore(preload()) + true + } +} diff --git a/jscomp/test/record_debug_test.js b/jscomp/test/record_debug_test.js index 95eb13b763..9fa12e0962 100644 --- a/jscomp/test/record_debug_test.js +++ b/jscomp/test/record_debug_test.js @@ -65,7 +65,7 @@ var N0 = { f: N0_f }; -console.log(" hei " + v + " "); +console.log("hei", v); var a = [ 1, @@ -83,32 +83,14 @@ var c = [ 5 ]; -console.log(" " + a + " " + c + " "); +console.log(a, c); -var a_2 = "" + 3; - -var a_3 = "" + 3 + 3; - -var a_4 = "" + 3 + 3 + 3; - -var a_5 = " " + 3; - -var a$1 = [ - "", - "a", - a_2, - a_3, - a_4, - a_5 -]; - -eq("File \"record_debug_test.ml\", line 64, characters 3-10", a$1, [ +eq("File \"record_debug_test.ml\", line 64, characters 3-10", [ + "", + "a" + ], [ "", - "a", - "3", - "33", - "333", - " 3" + "a" ]); Mt.from_pair_suites("record_debug_test.ml", suites.contents); diff --git a/jscomp/test/record_debug_test.ml b/jscomp/test/record_debug_test.ml index dc4be27d07..21553ff638 100644 --- a/jscomp/test/record_debug_test.ml +++ b/jscomp/test/record_debug_test.ml @@ -50,17 +50,17 @@ end = struct external f : int -> int = "%identity" end -;; Js.log {j| hei $v |j} +;; Js.log2 "hei" v let a, c = (1,2,2,4,3) , [|1;2;3;4;5|] -;; Js.log {j| $a $c |j} +;; Js.log2 a c let%private i = 3 let%private a = - {j||j},{j|a|j},{j|$i|j}, {j|$i$i|j} ,{j|$i$i$i|j}, {j| $i|j} + {js||js},{js|a|js} ;; -eq __LOC__ a ("","a","3","33","333"," 3") +eq __LOC__ a ("","a") ;; Mt.from_pair_suites __FILE__ !suites \ No newline at end of file diff --git a/jscomp/test/sexp.ml b/jscomp/test/sexp.ml deleted file mode 100644 index 597dea6240..0000000000 --- a/jscomp/test/sexp.ml +++ /dev/null @@ -1,173 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Simple S-expression parsing/printing} *) - -type t = [ - | `Atom of string - | `List of t list - ] - -let equal a b = a = b - -let compare a b = Pervasives.compare a b - -let hash a = Hashtbl.hash a - -let of_int x = `Atom (string_of_int x) -let of_float x = `Atom (string_of_float x) -let of_bool x = `Atom (string_of_bool x) -let atom x = `Atom x -let of_unit = `List [] -let of_list l = `List l -let of_rev_list l = `List (List.rev l) -let of_pair (x,y) = `List[x;y] -let of_triple (x,y,z) = `List[x;y;z] -let of_quad (x,y,z,u) = `List[x;y;z;u] - -let of_variant name args = `List (`Atom name :: args) -let of_field name t = `List [`Atom name; t] -let of_record l = - `List (List.map (fun (n,x) -> of_field n x) l) - -(** {6 Traversal of S-exp} *) - -module Traverse = struct - type 'a conv = t -> 'a option - - let return x = Some x - - let (>|=) e f = match e with - | None -> None - | Some x -> Some (f x) - - let (>>=) e f = match e with - | None -> None - | Some x -> f x - - let map_opt f l = - let rec recurse acc l = match l with - | [] -> Some (List.rev acc) - | x::l' -> - match f x with - | None -> None - | Some y -> recurse (y::acc) l' - in recurse [] l - - let rec _list_any f l = match l with - | [] -> None - | x::tl -> - match f x with - | Some _ as res -> res - | None -> _list_any f tl - - let list_any f e = match e with - | `Atom _ -> None - | `List l -> _list_any f l - - let rec _list_all f acc l = match l with - | [] -> List.rev acc - | x::tl -> - match f x with - | Some y -> _list_all f (y::acc) tl - | None -> _list_all f acc tl - - let list_all f e = match e with - | `Atom _ -> [] - | `List l -> _list_all f [] l - - let _try_atom e f = match e with - | `List _ -> None - | `Atom x -> try Some (f x) with _ -> None - - let to_int e = _try_atom e int_of_string - let to_bool e = _try_atom e bool_of_string - let to_float e = _try_atom e float_of_string - let to_string e = _try_atom e (fun x->x) - - let to_pair e = match e with - | `List [x;y] -> Some (x,y) - | _ -> None - - let to_pair_with f1 f2 e = - to_pair e >>= fun (x,y) -> - f1 x >>= fun x -> - f2 y >>= fun y -> - return (x,y) - - let to_triple e = match e with - | `List [x;y;z] -> Some (x,y,z) - | _ -> None - - let to_triple_with f1 f2 f3 e = - to_triple e >>= fun (x,y,z) -> - f1 x >>= fun x -> - f2 y >>= fun y -> - f3 z >>= fun z -> - return (x,y,z) - - let to_list e = match e with - | `List l -> Some l - | `Atom _ -> None - - let to_list_with f (e:t) = match e with - | `List l -> map_opt f l - | `Atom _ -> None - - let rec _get_field name l = match l with - | `List [`Atom n; x] :: _ when name=n -> Some x - | _ :: tl -> _get_field name tl - | [] -> None - - let get_field name e = match e with - | `List l -> _get_field name l - | `Atom _ -> None - - let field name f e = - get_field name e >>= f - - let rec _get_field_list name l = match l with - | `List (`Atom n :: tl) :: _ when name=n -> Some tl - | _ :: tl -> _get_field_list name tl - | [] -> None - - let field_list name f e = match e with - | `List l -> _get_field_list name l >>= f - | `Atom _ -> None - - let rec _get_variant s args l = match l with - | [] -> None - | (s', f) :: _ when s=s' -> f args - | _ :: tl -> _get_variant s args tl - - let get_variant l e = match e with - | `List (`Atom s :: args) -> _get_variant s args l - | `List _ -> None - | `Atom s -> _get_variant s [] l - - let get_exn e = match e with - | None -> failwith "CCSexp.Traverse.get_exn" - | Some x -> x -end diff --git a/jscomp/test/sexp.mli b/jscomp/test/sexp.mli deleted file mode 100644 index 5c42372158..0000000000 --- a/jscomp/test/sexp.mli +++ /dev/null @@ -1,168 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Handling S-expressions} - - @since 0.4 - - @since 0.7 - Moved the streaming parser to CCSexpStream -*) - -(** {2 Basics} *) - -type t = [ - | `Atom of string - | `List of t list -] - -val equal : t -> t -> bool -val compare : t -> t -> int -val hash : t -> int - -val atom : string -> t (** Build an atom directly from a string *) - -val of_int : int -> t -val of_bool : bool -> t -val of_list : t list -> t -val of_rev_list : t list -> t (** Reverse the list *) -val of_float : float -> t -val of_unit : t -val of_pair : t * t -> t -val of_triple : t * t * t -> t -val of_quad : t * t * t * t -> t - -val of_variant : string -> t list -> t -(** [of_variant name args] is used to encode algebraic variants - into a S-expr. For instance [of_variant "some" [of_int 1]] - represents the value [Some 1] *) - -val of_field : string -> t -> t -(** Used to represent one record field *) - -val of_record : (string * t) list -> t -(** Represent a record by its named fields *) - -(** {6 Traversal of S-exp} - - Example: serializing 2D points - {[ - type pt = {x:int; y:int };; - - let pt_of_sexp e = - Sexp.Traverse.( - field "x" to_int e >>= fun x -> - field "y" to_int e >>= fun y -> - return {x;y} - );; - - let sexp_of_pt pt = Sexp.(of_record ["x", of_int pt.x; "y", of_int pt.y]);; - - let l = [{x=1;y=1}; {x=2;y=10}];; - - let sexp = Sexp.(of_list (List.map sexp_of_pt l));; - - Sexp.Traverse.list_all pt_of_sexp sexp;; - ]} - -*) - -module Traverse : sig - type 'a conv = t -> 'a option - (** A converter from S-expressions to 'a is a function [sexp -> 'a option]. - @since 0.4.1 *) - - val map_opt : ('a -> 'b option) -> 'a list -> 'b list option - (** Map over a list, failing as soon as the function fails on any element - @since 0.4.1 *) - - val list_any : 'a conv -> t -> 'a option - (** [list_any f (List l)] tries [f x] for every element [x] in [List l], - and returns the first non-None result (if any). *) - - val list_all : 'a conv -> t -> 'a list - (** [list_all f (List l)] returns the list of all [y] such that [x] in [l] - and [f x = Some y] *) - - val to_int : int conv - (** Expect an integer *) - - val to_string : string conv - (** Expect a string (an atom) *) - - val to_bool : bool conv - (** Expect a boolean *) - - val to_float : float conv - (** Expect a float *) - - val to_list : t list conv - (** Expect a list *) - - val to_list_with : (t -> 'a option) -> 'a list conv - (** Expect a list, applies [f] to all the elements of the list, and succeeds - only if [f] succeeded on every element - @since 0.4.1 *) - - val to_pair : (t * t) conv - (** Expect a list of two elements *) - - val to_pair_with : 'a conv -> 'b conv -> ('a * 'b) conv - (** Same as {!to_pair} but applies conversion functions - @since 0.4.1 *) - - val to_triple : (t * t * t) conv - - val to_triple_with : 'a conv -> 'b conv -> 'c conv -> ('a * 'b * 'c) conv - (* @since 0.4.1 *) - - val get_field : string -> t conv - (** [get_field name e], when [e = List [(n1,x1); (n2,x2) ... ]], extracts - the [xi] such that [name = ni], if it can find it. *) - - val field : string -> 'a conv -> 'a conv - (** Enriched version of {!get_field}, with a converter as argument *) - - val get_variant : (string * (t list -> 'a option)) list -> 'a conv - (** [get_variant l e] checks whether [e = List (Atom s :: args)], and - if some pair of [l] is [s, f]. In this case, it calls [f args] - and returns its result, otherwise it returns None. *) - - val field_list : string -> (t list -> 'a option) -> 'a conv - (** [field_list name f "(... (name a b c d) ...record)"] - will look for a field based on the given [name], and expect it to have a - list of arguments dealt with by [f] (here, "a b c d"). - @since 0.4.1 *) - - val (>>=) : 'a option -> ('a -> 'b option) -> 'b option - - val (>|=) : 'a option -> ('a -> 'b) -> 'b option - - val return : 'a -> 'a option - - val get_exn : 'a option -> 'a - (** Unwrap an option, possibly failing. - @raise Invalid_argument if the argument is [None] *) -end diff --git a/jscomp/test/sexp.res b/jscomp/test/sexp.res new file mode 100644 index 0000000000..ef95024c24 --- /dev/null +++ b/jscomp/test/sexp.res @@ -0,0 +1,186 @@ +/*** {1 Simple S-expression parsing/printing} */ + +type rec t = [ + | #Atom(string) + | #List(list) +] + +let equal = (a, b) => a == b + +let compare = (a, b) => Pervasives.compare(a, b) + +let hash = a => Hashtbl.hash(a) + +let of_int = x => #Atom(string_of_int(x)) +let of_float = x => #Atom(string_of_float(x)) +let of_bool = x => #Atom(string_of_bool(x)) +let atom = x => #Atom(x) +let of_unit = #List(list{}) +let of_list = l => #List(l) +let of_rev_list = l => #List(List.rev(l)) +let of_pair = ((x, y)) => #List(list{x, y}) +let of_triple = ((x, y, z)) => #List(list{x, y, z}) +let of_quad = ((x, y, z, u)) => #List(list{x, y, z, u}) + +let of_variant = (name, args) => #List(list{#Atom(name), ...args}) +let of_field = (name, t) => #List(list{#Atom(name), t}) +let of_record = l => #List(List.map(((n, x)) => of_field(n, x), l)) + +/*** {6 Traversal of S-exp} */ + +module Traverse = { + type conv<'a> = t => option<'a> + + let return = x => Some(x) + + let \">|=" = (e, f) => + switch e { + | None => None + | Some(x) => Some(f(x)) + } + + let \">>=" = (e, f) => + switch e { + | None => None + | Some(x) => f(x) + } + + let map_opt = (f, l) => { + let rec recurse = (acc, l) => + switch l { + | list{} => Some(List.rev(acc)) + | list{x, ...l'} => + switch f(x) { + | None => None + | Some(y) => recurse(list{y, ...acc}, l') + } + } + recurse(list{}, l) + } + + let rec _list_any = (f, l) => + switch l { + | list{} => None + | list{x, ...tl} => + switch f(x) { + | Some(_) as res => res + | None => _list_any(f, tl) + } + } + + let list_any = (f, e) => + switch e { + | #Atom(_) => None + | #List(l) => _list_any(f, l) + } + + let rec _list_all = (f, acc, l) => + switch l { + | list{} => List.rev(acc) + | list{x, ...tl} => + switch f(x) { + | Some(y) => _list_all(f, list{y, ...acc}, tl) + | None => _list_all(f, acc, tl) + } + } + + let list_all = (f, e) => + switch e { + | #Atom(_) => list{} + | #List(l) => _list_all(f, list{}, l) + } + + let _try_atom = (e, f) => + switch e { + | #List(_) => None + | #Atom(x) => + try Some(f(x)) catch { + | _ => None + } + } + + let to_int = e => _try_atom(e, int_of_string) + let to_bool = e => _try_atom(e, bool_of_string) + let to_float = e => _try_atom(e, float_of_string) + let to_string = e => _try_atom(e, x => x) + + let to_pair = e => + switch e { + | #List(list{x, y}) => Some(x, y) + | _ => None + } + + let to_pair_with = (f1, f2, e) => + \">>="(to_pair(e), ((x, y)) => \">>="(f1(x), x => \">>="(f2(y), y => return((x, y))))) + + let to_triple = e => + switch e { + | #List(list{x, y, z}) => Some(x, y, z) + | _ => None + } + + let to_triple_with = (f1, f2, f3, e) => + \">>="(to_triple(e), ((x, y, z)) => + \">>="(f1(x), x => \">>="(f2(y), y => \">>="(f3(z), z => return((x, y, z))))) + ) + + let to_list = e => + switch e { + | #List(l) => Some(l) + | #Atom(_) => None + } + + let to_list_with = (f, e: t) => + switch e { + | #List(l) => map_opt(f, l) + | #Atom(_) => None + } + + let rec _get_field = (name, l) => + switch l { + | list{#List(list{#Atom(n), x}), ..._} if name == n => Some(x) + | list{_, ...tl} => _get_field(name, tl) + | list{} => None + } + + let get_field = (name, e) => + switch e { + | #List(l) => _get_field(name, l) + | #Atom(_) => None + } + + let field = (name, f, e) => \">>="(get_field(name, e), f) + + let rec _get_field_list = (name, l) => + switch l { + | list{#List(list{#Atom(n), ...tl}), ..._} if name == n => Some(tl) + | list{_, ...tl} => _get_field_list(name, tl) + | list{} => None + } + + let field_list = (name, f, e) => + switch e { + | #List(l) => \">>="(_get_field_list(name, l), f) + | #Atom(_) => None + } + + let rec _get_variant = (s, args, l) => + switch l { + | list{} => None + | list{(s', f), ..._} if s == s' => f(args) + | list{_, ...tl} => _get_variant(s, args, tl) + } + + let get_variant = (l, e) => + switch e { + | #List(list{#Atom(s), ...args}) => _get_variant(s, args, l) + | #List(_) => None + | #Atom(s) => _get_variant(s, list{}, l) + } + + let get_exn = e => + switch e { + | None => failwith("CCSexp.Traverse.get_exn") + | Some(x) => x + } +} diff --git a/jscomp/test/sexp.resi b/jscomp/test/sexp.resi new file mode 100644 index 0000000000..f885d0fa37 --- /dev/null +++ b/jscomp/test/sexp.resi @@ -0,0 +1,146 @@ +/*** {1 Handling S-expressions} + + @since 0.4 + + @since 0.7 + Moved the streaming parser to CCSexpStream +*/ + +/*** {2 Basics} */ + +type rec t = [ + | #Atom(string) + | #List(list) +] + +let equal: (t, t) => bool +let compare: (t, t) => int +let hash: t => int + +/** Build an atom directly from a string */ +let atom: string => t + +let of_int: int => t +let of_bool: bool => t +let of_list: list => t +/** Reverse the list */ +let of_rev_list: list => t +/** Reverse the list */ +let of_float: float => t +let of_unit: t +let of_pair: ((t, t)) => t +let of_triple: ((t, t, t)) => t +let of_quad: ((t, t, t, t)) => t + +/** [of_variant name args] is used to encode algebraic variants + into a S-expr. For instance [of_variant \"some\" [of_int 1]] + represents the value [Some 1] */ +let of_variant: (string, list) => t + +/** Used to represent one record field */ +let of_field: (string, t) => t + +/** Represent a record by its named fields */ +let of_record: list<(string, t)> => t + +@@ocaml.text(" {6 Traversal of S-exp} + + Example: serializing 2D points + {[ + type pt = {x:int; y:int };; + + let pt_of_sexp e = + Sexp.Traverse.( + field \"x\" to_int e >>= fun x -> + field \"y\" to_int e >>= fun y -> + return {x;y} + );; + + let sexp_of_pt pt = Sexp.(of_record [\"x\", of_int pt.x; \"y\", of_int pt.y]);; + + let l = [{x=1;y=1}; {x=2;y=10}];; + + let sexp = Sexp.(of_list (List.map sexp_of_pt l));; + + Sexp.Traverse.list_all pt_of_sexp sexp;; + ]} + +") + +module Traverse: { + /** A converter from S-expressions to 'a is a function [sexp -> 'a option]. + @since 0.4.1 */ + type conv<'a> = t => option<'a> + + /** Map over a list, failing as soon as the function fails on any element + @since 0.4.1 */ + let map_opt: ('a => option<'b>, list<'a>) => option> + + /** [list_any f (List l)] tries [f x] for every element [x] in [List l], + and returns the first non-None result (if any). */ + let list_any: (conv<'a>, t) => option<'a> + + /** [list_all f (List l)] returns the list of all [y] such that [x] in [l] + and [f x = Some y] */ + let list_all: (conv<'a>, t) => list<'a> + + /** Expect an integer */ + let to_int: conv + + /** Expect a string (an atom) */ + let to_string: conv + + /** Expect a boolean */ + let to_bool: conv + + /** Expect a float */ + let to_float: conv + + /** Expect a list */ + let to_list: conv> + + /** Expect a list, applies [f] to all the elements of the list, and succeeds + only if [f] succeeded on every element + @since 0.4.1 */ + let to_list_with: (t => option<'a>) => conv> + + /** Expect a list of two elements */ + let to_pair: conv<(t, t)> + + /** Same as {!to_pair} but applies conversion functions + @since 0.4.1 */ + let to_pair_with: (conv<'a>, conv<'b>) => conv<('a, 'b)> + + let to_triple: conv<(t, t, t)> + + let to_triple_with: (conv<'a>, conv<'b>, conv<'c>) => conv<('a, 'b, 'c)> + /* @since 0.4.1 */ + + /** [get_field name e], when [e = List [(n1,x1); (n2,x2) ... ]], extracts + the [xi] such that [name = ni], if it can find it. */ + let get_field: string => conv + + /** Enriched version of {!get_field}, with a converter as argument */ + let field: (string, conv<'a>) => conv<'a> + + /** [get_variant l e] checks whether [e = List (Atom s :: args)], and + if some pair of [l] is [s, f]. In this case, it calls [f args] + and returns its result, otherwise it returns None. */ + let get_variant: list<(string, list => option<'a>)> => conv<'a> + + /** [field_list name f \"(... (name a b c d) ...record)\"] + will look for a field based on the given [name], and expect it to have a + list of arguments dealt with by [f] (here, \"a b c d\"). + @since 0.4.1 */ + let field_list: (string, list => option<'a>) => conv<'a> + + let \">>=": (option<'a>, 'a => option<'b>) => option<'b> + + let \">|=": (option<'a>, 'a => 'b) => option<'b> + + let return: 'a => option<'a> + + /** Unwrap an option, possibly failing. + @raise Invalid_argument if the argument is [None] */ + let get_exn: option<'a> => 'a +} diff --git a/jscomp/test/sexpm.js b/jscomp/test/sexpm.js index 3c2066e2d9..969c8cb9ab 100644 --- a/jscomp/test/sexpm.js +++ b/jscomp/test/sexpm.js @@ -182,7 +182,7 @@ function _error(param) { var col = param.col; return function (msg) { var b = $$Buffer.create(32); - $$Buffer.add_string(b, "at " + line + ", " + col + ": "); + $$Buffer.add_string(b, "at " + (line + (", " + (col + ": ")))); $$Buffer.add_string(b, msg); var msg$p = $$Buffer.contents(b); return { @@ -461,7 +461,7 @@ function escaped(k, t) { return Curry._1(k, Char.chr(n)); }), t); } else { - return _error(t)("unexpected escaped char '" + c + "'"); + return _error(t)("unexpected escaped char '" + (c + "'")); } } @@ -475,7 +475,7 @@ function read2int(i, k, t) { if (_is_digit(c)) { return read1int(Math.imul(10, i) + (c - /* '0' */48 | 0) | 0, k, t); } else { - return _error(t)("unexpected char '" + c + "' when reading byte"); + return _error(t)("unexpected escaped char '" + (c + "' when reading byte")); } } @@ -489,7 +489,7 @@ function read1int(i, k, t) { if (_is_digit(c)) { return Curry._1(k, Math.imul(10, i) + (c - /* '0' */48 | 0) | 0); } else { - return _error(t)("unexpected char '" + c + "' when reading byte"); + return _error(t)("unexpected escaped char '" + (c + "' when reading byte")); } } diff --git a/jscomp/test/sexpm.ml b/jscomp/test/sexpm.ml index ba76514aa8..c179efbff8 100644 --- a/jscomp/test/sexpm.ml +++ b/jscomp/test/sexpm.ml @@ -105,7 +105,7 @@ module MakeDecode(M : MONAD) = struct (* return an error *) let _error {line;col} (msg : string) = let b = Buffer.create 32 in - Buffer.add_string b {j|at $(line), $(col): |j} ; + Buffer.add_string b ("at " ^ (__unsafe_cast line) ^ ", " ^ (__unsafe_cast col) ^ ": ") ; Buffer.add_string b msg; let msg' = Buffer.contents b in M.return (`Error msg') @@ -196,19 +196,19 @@ module MakeDecode(M : MONAD) = struct | '"' -> k '"' | c when _is_digit c -> read2int (_digit2i c) (fun n -> k (Char.chr n)) t - | c -> _error t {j|unexpected escaped char '$(c)'|j} + | c -> _error t ("unexpected escaped char '" ^ (__unsafe_cast c) ^ "'") and read2int i k t = if t.i = t.len then _refill t (read2int i k) _error_eof else match _get t with | c when _is_digit c -> read1int (10 * i + _digit2i c) k t - | c -> _error t {j|unexpected char '$(c)' when reading byte|j} + | c -> _error t ("unexpected escaped char '" ^ (__unsafe_cast c) ^ "' when reading byte") and read1int i k t = if t.i = t.len then _refill t (read1int i k) _error_eof else match _get t with | c when _is_digit c -> k (10 * i + _digit2i c) - | c -> _error t {j|unexpected char '$(c)' when reading byte|j} + | c -> _error t ("unexpected escaped char '" ^ (__unsafe_cast c) ^ "' when reading byte") (* skip until end of line, then call next() *) and skip_comment k t = diff --git a/jscomp/test/string_interp_test.js b/jscomp/test/string_interp_test.js deleted file mode 100644 index 6f1c89493e..0000000000 --- a/jscomp/test/string_interp_test.js +++ /dev/null @@ -1,93 +0,0 @@ -'use strict'; - - -function hi2(xx, yy, zz) { - return "\n" + xx + " " + yy + "\n\n" + zz + "\n"; -} - -function hi(a0, b0, xx, yy, zz) { - return "\n零一二三四五六七八九 " + a0 + "\n零一二三四五六七八九 123456789 " + b0 + "\n测试一段中文 " + xx + ", " + yy + "\n" + zz + "\n\n"; -} - -function a3(world) { - return "Hello \\" + world; -} - -function a5(x) { - return "" + x; -} - -function a6(x) { - return "" + x; -} - -function a7(x0, x3, x5) { - return "\\" + x0 + ",\$x1,\\\$x2,\\\\" + x3 + ", \\\\\$x4,\\\\\\" + x5; -} - -function ffff(a_1, a_2) { - return " hello " + a_1 + ", wlecome to " + a_2 + " "; -} - -function f(x, y) { - var sum = x + y | 0; - console.log(" " + x + " + " + y + " = " + sum + " "); -} - -var world = "世界"; - -var hello_world = "你好，" + world; - -function test1(x0) { - return "你好，" + x0; -} - -function test3(_xg) { - return "你好，" + _xg; -} - -function test5(x) { - return "" + x; -} - -var js_in_raw = ("hello" + "你好"); - -var j_in_raw = ("hello" + "你好"); - -var b = "test"; - -var c = "test"; - -var a = "test"; - -var a0 = "Hello \\"; - -var a1 = "Hello \\"; - -var a2 = "Hello \$"; - -var a4 = ""; - -exports.hi2 = hi2; -exports.hi = hi; -exports.b = b; -exports.c = c; -exports.a = a; -exports.a0 = a0; -exports.a1 = a1; -exports.a2 = a2; -exports.a3 = a3; -exports.a4 = a4; -exports.a5 = a5; -exports.a6 = a6; -exports.a7 = a7; -exports.ffff = ffff; -exports.f = f; -exports.world = world; -exports.hello_world = hello_world; -exports.test1 = test1; -exports.test3 = test3; -exports.test5 = test5; -exports.js_in_raw = js_in_raw; -exports.j_in_raw = j_in_raw; -/* js_in_raw Not a pure module */ diff --git a/jscomp/test/string_interp_test.ml b/jscomp/test/string_interp_test.ml deleted file mode 100644 index f05a925954..0000000000 --- a/jscomp/test/string_interp_test.ml +++ /dev/null @@ -1,60 +0,0 @@ -let hi2 xx yy (zz : int) = {j| -$xx $yy - -$zz -|j} - -let hi a0 b0 xx yy zz = {j| -零一二三四五六七八九 $a0 -零一二三四五六七八九 123456789 $b0 -测试一段中文 $xx, $yy -$zz - -|j} - - -let b = {xx|test|xx} -let c = {js|test|js} -let a = {j|test|j} -let a0 = {js|Hello \\|js} -let a1 = {j|Hello \\|j} -let a2 = {j|Hello \$|j} -let a3 world = {j|Hello \\$world|j} -let a4 = {j||j} -let a5 x = {j|$x|j} -let a6 x = {j|$(x)|j} - -let a7 x0 x3 x5 - = {j|\\$x0,\$x1,\\\$x2,\\\\$x3, \\\\\$x4,\\\\\\$x5|j} - -let ffff a_1 a_2 = {j| hello $a_1, wlecome to $(a_2) |j} - - -(* let test = {j| -|j} *) - -let f x y = - let sum = x + y in - Js.log {j| $x + $y = $sum |j} - - - - -let world = {j|世界|j} -let hello_world = {j|你好，$world|j} - - - -let test1 x0 = {j|你好，$x0|j} - -let test3 _xg = {j|你好，$_xg|j} - - - -let test5 x = {j|$(x)|j} - - -let js_in_raw = [%raw{js|"hello" + "你好"|js}] -let j_in_raw = [%raw{j|"hello" + "你好"|j}] - - diff --git a/jscomp/test/ticker.ml b/jscomp/test/ticker.ml index 37e887d51a..eeda5605e4 100644 --- a/jscomp/test/ticker.ml +++ b/jscomp/test/ticker.ml @@ -56,7 +56,7 @@ and ticker = { let string_of_rank = function | Uninitialized -> "Uninitialized" | Visited -> "Visited" - | Ranked i -> {j|Ranked($i)|j} + | Ranked i -> ("Ranked(" ^ (__unsafe_cast i)) ^ ")" let find_ticker_by_name all_tickers ticker = List.find (fun {ticker_name;_ } -> ticker_name = ticker) all_tickers diff --git a/lib/es6/arg.js b/lib/es6/arg.js index d06e30c509..3d93834f39 100644 --- a/lib/es6/arg.js +++ b/lib/es6/arg.js @@ -132,7 +132,7 @@ function usage_b(buf, speclist, errmsg) { return $$Buffer.add_string(buf, " " + key + " " + doc + "\n"); } var sym = make_symlist("{", "|", "}", spec._0); - return $$Buffer.add_string(buf, " " + key + " " + sym + doc + "\n"); + return $$Buffer.add_string(buf, " " + key + " " + sym + "" + doc + "\n"); }), add_help(speclist)); } diff --git a/lib/es6/printexc.js b/lib/es6/printexc.js deleted file mode 100644 index 87f7736896..0000000000 --- a/lib/es6/printexc.js +++ /dev/null @@ -1,102 +0,0 @@ - - -import * as Curry from "./curry.js"; -import * as Pervasives from "./pervasives.js"; -import * as Caml_exceptions from "./caml_exceptions.js"; -import * as Caml_js_exceptions from "./caml_js_exceptions.js"; - -var printers = { - contents: /* [] */0 -}; - -function locfmt(s, linum, start, finish, msg) { - return "File \"" + s + "\", line " + linum + ", characters " + start + "-" + finish + ": " + msg; -} - -var fields = (function(x){ - var s = "" - var index = 1 - while ("_"+index in x){ - s += x ["_" + index]; - ++ index - } - if(index === 1){ - return s - } - return "(" + s + ")" -}); - -function to_string(x) { - var _param = printers.contents; - while(true) { - var param = _param; - if (param) { - var s; - try { - s = Curry._1(param.hd, x); - } - catch (exn){ - s = undefined; - } - if (s !== undefined) { - return s; - } - _param = param.tl; - continue ; - } - if (x.RE_EXN_ID === "Match_failure") { - var match = x._1; - var $$char = match[2]; - return locfmt(match[0], match[1], $$char, $$char + 5 | 0, "Pattern matching failed"); - } - if (x.RE_EXN_ID === "Assert_failure") { - var match$1 = x._1; - var $$char$1 = match$1[2]; - return locfmt(match$1[0], match$1[1], $$char$1, $$char$1 + 6 | 0, "Assertion failed"); - } - if (x.RE_EXN_ID === "Undefined_recursive_module") { - var match$2 = x._1; - var $$char$2 = match$2[2]; - return locfmt(match$2[0], match$2[1], $$char$2, $$char$2 + 6 | 0, "Undefined recursive module"); - } - var constructor = Caml_exceptions.exn_slot_name(x); - return constructor + fields(x); - }; -} - -function print(fct, arg) { - try { - return Curry._1(fct, arg); - } - catch (raw_x){ - var x = Caml_js_exceptions.internalToOCamlException(raw_x); - console.log("Uncaught exception: " + to_string(x)); - throw x; - } -} - -function $$catch(fct, arg) { - try { - return Curry._1(fct, arg); - } - catch (raw_x){ - var x = Caml_js_exceptions.internalToOCamlException(raw_x); - console.log("Uncaught exception: " + to_string(x)); - return Pervasives.exit(2); - } -} - -function register_printer(fn) { - printers.contents = { - hd: fn, - tl: printers.contents - }; -} - -export { - to_string , - print , - $$catch , - register_printer , -} -/* No side effect */ diff --git a/lib/js/arg.js b/lib/js/arg.js index 91b9fa1f88..733c5d2db7 100644 --- a/lib/js/arg.js +++ b/lib/js/arg.js @@ -132,7 +132,7 @@ function usage_b(buf, speclist, errmsg) { return $$Buffer.add_string(buf, " " + key + " " + doc + "\n"); } var sym = make_symlist("{", "|", "}", spec._0); - return $$Buffer.add_string(buf, " " + key + " " + sym + doc + "\n"); + return $$Buffer.add_string(buf, " " + key + " " + sym + "" + doc + "\n"); }), add_help(speclist)); } diff --git a/lib/js/printexc.js b/lib/js/printexc.js deleted file mode 100644 index 62cd34b55d..0000000000 --- a/lib/js/printexc.js +++ /dev/null @@ -1,100 +0,0 @@ -'use strict'; - -var Curry = require("./curry.js"); -var Pervasives = require("./pervasives.js"); -var Caml_exceptions = require("./caml_exceptions.js"); -var Caml_js_exceptions = require("./caml_js_exceptions.js"); - -var printers = { - contents: /* [] */0 -}; - -function locfmt(s, linum, start, finish, msg) { - return "File \"" + s + "\", line " + linum + ", characters " + start + "-" + finish + ": " + msg; -} - -var fields = (function(x){ - var s = "" - var index = 1 - while ("_"+index in x){ - s += x ["_" + index]; - ++ index - } - if(index === 1){ - return s - } - return "(" + s + ")" -}); - -function to_string(x) { - var _param = printers.contents; - while(true) { - var param = _param; - if (param) { - var s; - try { - s = Curry._1(param.hd, x); - } - catch (exn){ - s = undefined; - } - if (s !== undefined) { - return s; - } - _param = param.tl; - continue ; - } - if (x.RE_EXN_ID === "Match_failure") { - var match = x._1; - var $$char = match[2]; - return locfmt(match[0], match[1], $$char, $$char + 5 | 0, "Pattern matching failed"); - } - if (x.RE_EXN_ID === "Assert_failure") { - var match$1 = x._1; - var $$char$1 = match$1[2]; - return locfmt(match$1[0], match$1[1], $$char$1, $$char$1 + 6 | 0, "Assertion failed"); - } - if (x.RE_EXN_ID === "Undefined_recursive_module") { - var match$2 = x._1; - var $$char$2 = match$2[2]; - return locfmt(match$2[0], match$2[1], $$char$2, $$char$2 + 6 | 0, "Undefined recursive module"); - } - var constructor = Caml_exceptions.exn_slot_name(x); - return constructor + fields(x); - }; -} - -function print(fct, arg) { - try { - return Curry._1(fct, arg); - } - catch (raw_x){ - var x = Caml_js_exceptions.internalToOCamlException(raw_x); - console.log("Uncaught exception: " + to_string(x)); - throw x; - } -} - -function $$catch(fct, arg) { - try { - return Curry._1(fct, arg); - } - catch (raw_x){ - var x = Caml_js_exceptions.internalToOCamlException(raw_x); - console.log("Uncaught exception: " + to_string(x)); - return Pervasives.exit(2); - } -} - -function register_printer(fn) { - printers.contents = { - hd: fn, - tl: printers.contents - }; -} - -exports.to_string = to_string; -exports.print = print; -exports.$$catch = $$catch; -exports.register_printer = register_printer; -/* No side effect */ diff --git a/packages/artifacts.txt b/packages/artifacts.txt index 9777725213..5f9019a24d 100644 --- a/packages/artifacts.txt +++ b/packages/artifacts.txt @@ -168,7 +168,6 @@ lib/es6/obj.js lib/es6/package.json lib/es6/parsing.js lib/es6/pervasives.js -lib/es6/printexc.js lib/es6/queue.js lib/es6/random.js lib/es6/set.js @@ -331,7 +330,6 @@ lib/js/node_process.js lib/js/obj.js lib/js/parsing.js lib/js/pervasives.js -lib/js/printexc.js lib/js/queue.js lib/js/random.js lib/js/set.js @@ -348,8 +346,8 @@ lib/minisocket.js lib/ocaml/arg.cmi lib/ocaml/arg.cmt lib/ocaml/arg.cmti -lib/ocaml/arg.ml -lib/ocaml/arg.mli +lib/ocaml/arg.res +lib/ocaml/arg.resi lib/ocaml/array.cmi lib/ocaml/array.cmt lib/ocaml/array.cmti @@ -874,11 +872,6 @@ lib/ocaml/pervasives.cmt lib/ocaml/pervasives.cmti lib/ocaml/pervasives.ml lib/ocaml/pervasives.mli -lib/ocaml/printexc.cmi -lib/ocaml/printexc.cmt -lib/ocaml/printexc.cmti -lib/ocaml/printexc.ml -lib/ocaml/printexc.mli lib/ocaml/queue.cmi lib/ocaml/queue.cmt lib/ocaml/queue.cmti diff --git a/scripts/ninja.js b/scripts/ninja.js index 99c97c0b0d..9202caf79c 100755 --- a/scripts/ninja.js +++ b/scripts/ninja.js @@ -578,10 +578,13 @@ function ocamlDepForBscAsync(files, dir, depsMap) { } try { const mlfile = path.join(tmpdir, mlname); - cp.execSync(`${bsc_exe} -dsource -only-parse ${f} 2>${mlfile}`, { - cwd: dir, - encoding: "ascii", - }); + cp.execSync( + `${bsc_exe} -dsource -only-parse -bs-no-builtin-ppx ${f} 2>${mlfile}`, + { + cwd: dir, + encoding: "ascii", + } + ); mlfiles.push(mlfile); } catch (err) { console.log(err); @@ -811,16 +814,16 @@ function generateNinja(depsMap, allTargets, cwd, extraDeps = []) { break; case "HAS_BOTH_RES": mk([ouptput_cmj], [input_res], "cc_cmi"); - mk([output_cmi], [input_resi], "cc"); + mk([output_cmi], [input_resi]); break; case "HAS_RES": - mk([output_cmi, ouptput_cmj], [input_res], "cc"); + mk([output_cmi, ouptput_cmj], [input_res]); break; case "HAS_ML": mk([output_cmi, ouptput_cmj], [input_ml]); break; case "HAS_RESI": - mk([output_cmi], [input_resi], "cc"); + mk([output_cmi], [input_resi]); break; case "HAS_MLI": mk([output_cmi], [input_mli]); @@ -1098,7 +1101,11 @@ ${ninjaQuickBuidList([ var stdlibDirFiles = fs.readdirSync(stdlibDir, "ascii"); var sources = stdlibDirFiles.filter(x => { return ( - !x.startsWith("pervasives") && (x.endsWith(".ml") || x.endsWith(".mli")) + !x.startsWith("pervasives") && + (x.endsWith(".ml") || + x.endsWith(".mli") || + x.endsWith(".res") || + x.endsWith(".resi")) ); }); let depsMap = new Map(); @@ -1112,9 +1119,12 @@ ${ninjaQuickBuidList([ switch (ext) { case "HAS_MLI": case "HAS_BOTH": + case "HAS_RESI": + case "HAS_BOTH_RES": updateDepsKVByFile(mod + ".cmi", "pervasives.cmj", depsMap); break; case "HAS_ML": + case "HAS_RES": updateDepsKVByFile(mod + ".cmj", "pervasives.cmj", depsMap); break; }